Subversion Repositories spacemission

Compare Revisions

No changes between revisions

Regard whitespace Rev HEAD → Rev 1

/VCL_DELPHIX_D6/DelphiX140.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX150.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX160.dproj
File deleted
/VCL_DELPHIX_D6/Dcu150
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DXMidiEdit.dfm
File deleted
/VCL_DELPHIX_D6/DelphiX170.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX180.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX190.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX140_Icon.ico
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/Dcu190
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DelphiX.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX100.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX200.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DXDIBEffectEdit.dfm
File deleted
/VCL_DELPHIX_D6/DelphiX120.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX220.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX140.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/turbopixels.pas
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX160.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX180.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DxPathEdit.dfm
File deleted
/VCL_DELPHIX_D6/Dcu220
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu120
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu160
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/SXMedia/SXEditor.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/SXAbout.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/SXModPlayer.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/SXAbout.dfm
File deleted
/VCL_DELPHIX_D6/SXMedia/SXReg.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/SXMovie.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/SxSample/SXMedia.dpr
File deleted
/VCL_DELPHIX_D6/SXMedia/SxSample/SXMedia.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/SXMedia/SxSample/main.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/SxSample/MPPSDK.DLL
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/SXMedia/SxSample/main.dfm
File deleted
/VCL_DELPHIX_D6/SXMedia/SxSample
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/SXMedia/SXReg.dcr
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/SXMedia/SXEngine.pas
File deleted
/VCL_DELPHIX_D6/SXMedia/MpSndSys.pas
File deleted
/VCL_DELPHIX_D6/SXMedia
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DXMapEdit.pas
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX110.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX210.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX.bdsproj
File deleted
/VCL_DELPHIX_D6/DelphiX150.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX200.otares
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX170.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX190.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/Dcu170
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DelphiX160_Icon.ico
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX30.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX40.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX50.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX60.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX70.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX90.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX110.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX210.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX150.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX170.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DelphiX190.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DXGlueItEdit.pas
File deleted
/VCL_DELPHIX_D6/DXGlueItEdit.dfm
File deleted
/VCL_DELPHIX_D6/DelphiX30.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX40.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX50.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX60.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX70.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX90.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/Dcu200
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu100
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DXMapEdit.dfm
File deleted
/VCL_DELPHIX_D6/Dcu140
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Colli3DX.pas
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/Colli3DX.dcr
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DXMidiEdit.pas
File deleted
/VCL_DELPHIX_D6/Dcu180
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DXMapEditProperties.pas
File deleted
/VCL_DELPHIX_D6/DXMisc.pas
File deleted
/VCL_DELPHIX_D6/DelphiX100.bdsproj
File deleted
/VCL_DELPHIX_D6/Dcu90
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu70
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu60
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu50
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu40
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu30
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/D3DUtils.pas
File deleted
/VCL_DELPHIX_D6/DXWave.pas
File deleted
/VCL_DELPHIX_D6/DXSpriteEdit.pas
File deleted
/VCL_DELPHIX_D6/DelphiX100.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX200.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX120.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX220.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DXSpriteEdit.dfm
File deleted
/VCL_DELPHIX_D6/DelphiX140.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DirectPlay.pas
File deleted
/VCL_DELPHIX_D6/DelphiX.dproj
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX160.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DxPathEdit.pas
File deleted
/VCL_DELPHIX_D6/DelphiX180.dpk
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DXMapEditProperties.dfm
File deleted
/VCL_DELPHIX_D6/DXDIBEffectEdit.pas
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX200.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX110.dproj
File deleted
\ No newline at end of file
/VCL_DELPHIX_D6/DelphiX210.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX120.dproj
File deleted
/VCL_DELPHIX_D6/DelphiX220.dproj
File deleted
/VCL_DELPHIX_D6/Dcu210
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/Dcu110
Property changes:
Deleted: svn:ignore
-*.local
-*.dcu
-*.~*
-*.identcache
-*.tvsconfig
-__history
-*.exe
/VCL_DELPHIX_D6/DXConsts.dcu
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/DirectX.txt
0,0 → 1,121
-- English -------------------------------------------------------------------
 
DirectX header for Delphi 3, 4, 5.
 
Present unit:
DirectX unit DirectX 7 (DirectX 7 SDK)
DShow unit DirectShow (DirectX Media SDK 5.1)
DAnim unit DirectAnimation (DirectX Media SDK 5.1)
 
Hiroyuki Hori
@hori@ingjapan.ne.jp
@http://www.yks.ne.jp/~hori/
 
-- Japanese -------------------------------------------------------------------
 
Delphi 3, 4, 5 —p‚ÌŠ®‘S‚È DirectX ƒwƒbƒ_[‚Å‚·B
 
Œ»Ý‚̃†ƒjƒbƒgF
DirectX ƒ†ƒjƒbƒg DirectX 7 (DirectX 7 SDK)
DShow ƒ†ƒjƒbƒg DirectShow (DirectX Media SDK 5.1)
DAnim ƒ†ƒjƒbƒg DirectAnimation (DirectX Media SDK 5.1)
 
–x@_s(Hiroyuki Hori)
@hori@ingjapan.ne.jp
@http://www.yks.ne.jp/~hori/
 
 
XV‹L˜^F
 
2000/07/17 EIDirectDrawSurface4.Lock ƒƒ\ƒbƒh‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3DDevice7.DrawIndexedPrimitiveVB ƒƒ\ƒbƒh‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1999/11/20 EDirectX7 ‚ɑΉž‚µ‚½B
EIDirectDrawSurface ƒCƒ“ƒ^[ƒtƒF[ƒX‚Ì EnumAttachedSurfaces, EnumOverlayZOrders ƒƒ\ƒbƒh‚Ì
ˆø”‚ÌŒ^‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3DRMFrame3 ƒCƒ“ƒ^[ƒtƒF[ƒX‚Ì GetTransForm ƒƒ\ƒbƒh‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EDDSPD_VOLATILE ’萔‚Ì’l‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EDShow.pas ‚Å Delphi 3 ‚̏ꍇAInt64 Œ^‚ðéŒ¾‚µ‚Ä‚¢‚½‚Ì‚ð‚â‚ß‚Ä LONGLONG Œ^‚ðŽg‚¤‚悤‚É‚µ‚½B
ETDPMsg_SendComplete Œ^‚Å dwPriority ‚ª”²‚¯‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1999/09/27 EDelphi 5 ‚ŃŒƒR[ƒh‚̉•ϕ”•ª‚ɃCƒ“ƒ^[ƒtƒF[ƒX‚ð‚¨‚¯‚È‚­‚È‚Á‚½‚½‚߁A
TDDBltFX, TDDOverlayFx \‘¢‘Ì‚Ì‚È‚©‚̃Cƒ“ƒ^[ƒtƒF[ƒX‚ðƒ|ƒCƒ“ƒ^‚ɕύX‚µ‚½B
 
1999/08/21 EDirectXFileCreate ŠÖ”‚Ì DLL ƒtƒ@ƒCƒ‹–¼‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIID_IDirectXFile ’萔‚È‚Ç‚ª•¶Žš—ñ’萔‚Æ‚µ‚Đ錾‚³‚ê‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
ED3DRM_XTEMPLATE_BYTES ’萔‚ðéŒ¾‚µ–Y‚ê‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3DRMMeshBuilder3 ƒCƒ“ƒ^[ƒtƒF[ƒX‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1999/02/21 EIDirect3DRM3 ƒCƒ“ƒ^[ƒtƒF[ƒX‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3DDevice3 ƒCƒ“ƒ^[ƒtƒF[ƒX‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/10/05@EIDirect3D3.CreateDevice ƒƒ\ƒbƒh‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/08/28@EIDirect3D3.CreateVertexBuffer ƒƒ\ƒbƒh‚ðéŒ¾‚µ–Y‚ê‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3D3.CreateMaterial ƒƒ\ƒbƒh‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/08/25 EIDirect3DRM ƒCƒ“ƒ^[ƒtƒF[ƒX‚ð’è‹`‚µ–Y‚ê‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3DRM2, IDirect3DRM3 ‚Ì LoadTextureFromResource ƒƒ\ƒbƒh‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/08/24 EDirectX 5 ƒwƒbƒ_[‚ƌ݊·«‚ª‚È‚©‚Á‚½‚Ì‚ðC³‚µ‚½B
‹ï‘Ì“I‚É‚Í PDInputState ‚ð’è‹`‚µ‚Ä‚¢‚È‚©‚Á‚½B
 
1998/08/08 EIBasicVideo.get_BitRate ƒƒ\ƒbƒh‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/08/07 EDirectX 6 ‚É‚à‘Ήž‚µ‚½B
EŒ^‚Ì–½–¼‹K‘¥‚ð Delphi •W€‚É•Ï‚¦‚½B
EInteger Œ^‚Ő錾‚µ‚Ä‚ ‚Á‚½‚Ì‚ð DWORD ‚© Longint Œ^‚Ő錾‚·‚é‚悤‚É‚µ‚½B
EƒrƒfƒIƒ|[ƒgŠÖ˜A‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
ETD3DRMLoadTextureCallback Œ^‚̈ø”‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIDirect3DRMPicked2Array.GetPick ƒƒ\ƒbƒh‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
ETDSEnumCallbackX Œ^‚É stdcall ‚ª–³‚©‚Á‚½‚Ì‚ðC³‚µ‚½B
EDShow ƒ†ƒjƒbƒg‚Å 64ƒrƒbƒg®”Œ^‚Í Comp ‚Å‚Í‚È‚­ATInt64 Œ^‚É‚µ‚½B
Delphi3 ‚Å‚Í type TInt64=Comp ‚Æ‚µ‚Ä’è‹`‚³‚ê‚éB
 
1998/06/03 EVectorCrossProduct ŠÖ”‚ÌŒvŽZŽ®‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/05/29 ED3DRMQuaternionFromRotation ŠÖ”‚̈ø”‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1998/04/29 EDIK_? ‚Ő錾‚µ–Y‚ê‚Ä‚¢‚½‚Ì‚ð’ljÁ‚µ‚½B
 
1998/04/02 EIDirect3DRMFrame2 ‚̃ƒ\ƒbƒh‚ðC³‚µ‚½B
 
1998/04/02 EDirectPlay ŠÖ˜A‚ð‚¿‚å‚Á‚ƏC³‚µ‚½B
 
1998/03/02 EIFilterMapper2.EnumMatchingFilters ‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
EIEnumXX.Next ƒƒ\ƒbƒh‚Ì‘æ“ñˆø” ‚Å out XXX: Ixxx ‚Æ‚È‚Á‚Ä‚¢‚½‚Ì‚ð out XXX ‚Æ‚µ‚½B
 
1998/03/01 EˆÈ‰º‚̃†ƒjƒbƒg‚ð’ljÁ‚µ‚½B
DShow ƒ†ƒjƒbƒg DirectShow(ActiveMovie)
DAnim ƒ†ƒjƒbƒg DirectAnimation
 
1998/02/06 EDirectX ƒ†ƒjƒbƒg‚É‚·‚ׂẴ†ƒjƒbƒg‚ð‚Ü‚Æ‚ß‚½B
 
1998/01/31 E‚·‚ׂẴ†ƒjƒbƒg‚É $WEAKPACKAGEUNIT Žw—ß‚ð‰Á‚¦‚½B
ED3DTypes ƒ†ƒjƒbƒg‚Ì D3DRGBA ŠÖ”‚ðC³‚µ‚½B
 
1998/01/22 E‚Ù‚Æ‚ñ‚ǂ̃†ƒjƒbƒg‚É $WEAKPACKAGEUNIT Žw—ß‚ð‰Á‚¦‚½B
 
1998/01/04 EDInput.pas ‚Ì DIK_xxx ‚Ő錾‚µ–Y‚ê‚Ä‚¢‚½‚Ì‚ª‚ ‚Á‚½‚Ì‚ðC³‚µ‚½B
 
1997/12/27 EIDirect3DRMDevice2 ‚ð IDirect3DRMDevice ‚ðŒp³‚·‚é‚悤‚É‚µ‚½B
EIDirect3DViewport2 ‚ð Direct3DViewport ‚ðŒp³‚·‚é‚悤‚É‚µ‚½B
EIDirectPlay3 ‚Å IDirectPlay2 ‚Ì•”•ª‚ªéŒ¾‚³‚ê‚Ä‚¢‚½‚Ì‚ðíœ‚µ‚½B
EIDirectPlayLobby2 ‚Å IDirectPlayLobby ‚Ì•”•ª‚ªéŒ¾‚³‚ê‚Ä‚¢‚½‚Ì‚ðíœ‚µ‚½B
EIDirectInputDevice2 ‚Å IDirectInputDevice ‚Ì•”•ª‚ªéŒ¾‚³‚ê‚Ä‚¢‚½‚Ì‚ðíœ‚µ‚½B
EƒR[ƒ‹ƒoƒbƒNŠÖ”‚Ì–ß‚è’l‚ð BOOL ‚©‚ç HRESULT ‚É‚µ‚½B
Ec_dfDIMouse, c_dfDIKeyboard ‚Ì’è‹`‚ª³‚µ‚­‚È‚©‚Á‚½‚Ì‚ð‚È‚¨‚µ‚½B
 
1997/12/16 EIDirect3DRM2.CreateDeviceFromD3D ƒƒ\ƒbƒh‚̈ø”‚ð•ÏX‚µ‚½B
EIDirect3DRMMeshBuilder2 ‚ð IDirect3DRMMeshBuilder ‚ðŒp³‚·‚é‚悤‚É‚µ‚½B
ED3DRMObj ƒ†ƒjƒbƒg‚Å Boolean ‚Æ‚È‚Á‚Ä‚¢‚½‚Ì‚ð Bool ‚Æ‚µ‚½B
 
1997/12/09 EIDirect3DRMFrame2 ‚ð IDirect3DRMFrame ‚ðŒp³‚·‚é‚悤‚É‚µ‚½B
EIDirect3DRMTexture2 ‚ð IDirect3DRMTexture ‚ðŒp³‚·‚é‚悤‚É‚µ‚½B
 
EIDirect3DDevice2 ‚Ì DrawPrimitve, DrawIndexedPrimitve ƒƒ\ƒbƒh‚̈ø”‚ð•ÏX‚µ‚½B
EIDirect3DRMFace ‚Ì SetColor ƒƒ\ƒbƒh‚̐錾‚ª”²‚¯—Ž‚¿‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
 
1997/11/25 ED3DTypes ƒ†ƒjƒbƒg‚Ì D3DRGB, D3DRGBA ŠÖ”‚ðC³‚µ‚½B
 
1997/11/21 EIDirect3DRMObject.Clone ƒƒ\ƒbƒh‚̐錾‚ªŠÔˆá‚Á‚Ä‚¢‚½‚Ì‚ðC³‚µ‚½B
/VCL_DELPHIX_D6/DIB.pas
1,40 → 1,13
{*******************************************************}
{ }
{ DIB and PAINTBOX componets }
{ }
{ Copyright (C) 1997-2000 Hiroyuki Hori }
{ base components and effects }
{ Copyright (C) 2000 Keith Murray }
{ supernova effect }
{ Copyright (C) 2000 Michel Hibon }
{ new special effects added for DIB }
{ Copyright (C) 2001 Joakim Back }
{ conFusion effects (as DxFusion) }
{ Copyright (C) 2003 Babak Sateli }
{ 24-bit DIB effect as supplement ones }
{ Copyright (C) 2004-2012 Jaro Benes }
{ 32-bit DIB effect with alphachannel }
{ direct works with texture buffer }
{ modified and adapted all adopted functions }
{ }
{*******************************************************}
 
unit DIB;
 
interface
 
{$INCLUDE DelphiXcfg.inc}
{$DEFINE USE_SCANLINE}
 
uses
Windows, SysUtils, Classes, Graphics, Controls,
{$IFDEF VER17UP} Types, UITypes,{$ENDIF}
Math;
Windows, SysUtils, Classes, Graphics, Controls;
 
type
TColorLineStyle = (csSolid, csGradient, csRainbow);
TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);
PRGBQuads = ^TRGBQuads;
TRGBQuads = array[0..255] of TRGBQuad;
 
TPaletteEntries = array[0..255] of TPaletteEntry;
44,16 → 17,6
B, G, R: Byte;
end;
 
{ Added this type for New SPecial Effect }
TFilter = array[0..2, 0..2] of SmallInt;
TLines = array[0..0] of TBGR;
PLines = ^TLines;
TBytes = array[0..0] of Byte;
PBytes = ^TBytes;
TPBytes = array[0..0] of PBytes;
PPBytes = ^TPBytes;
{ End of type's }
 
PArrayBGR = ^TArrayBGR;
TArrayBGR = array[0..10000] of TBGR;
 
66,7 → 29,7
PArrayDWord = ^TArrayDWord;
TArrayDWord = array[0..10000] of DWord;
 
{ TDIBPixelFormat }
{ TDIB }
 
TDIBPixelFormat = record
RBitMask, GBitMask, BBitMask: DWORD;
75,8 → 38,6
RBitCount2, GBitCount2, BBitCount2: DWORD;
end;
 
{ TDIBSharedImage }
 
TDIBSharedImage = class(TSharedImage)
private
FBitCount: Integer;
103,7 → 64,7
constructor Create;
procedure NewImage(AWidth, AHeight, ABitCount: Integer;
const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); {$IFDEF VER9UP}inline;{$ENDIF}
procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
procedure Compress(Source: TDIBSharedImage);
procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
procedure ReadData(Stream: TStream; MemoryImage: Boolean);
115,33 → 76,6
destructor Destroy; override;
end;
 
{ TFilterTypeResample }
 
TFilterTypeResample = (ftrBox, ftrTriangle, ftrHermite, ftrBell, ftrBSpline,
ftrLanczos3, ftrMitchell);
 
TDistortType = (dtFast, dtSlow);
{DXFusion effect type}
TFilterMode = (fmNormal, fmMix50, fmMix25, fmMix75);
 
{ TLightSource }
 
TLightSource = record
X, Y: Integer;
Size1, Size2: Integer;
Color: TColor;
end;
 
{ TLightArray }
 
TLightArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TLightsource;
 
{ TMatrixSetting }
 
TMatrixSetting = array[0..9] of Integer;
 
{ TDIB }
 
TDIB = class(TGraphic)
private
FCanvas: TCanvas;
162,10 → 96,6
FTopPBits: Pointer;
FWidth: Integer;
FWidthBytes: Integer;
FLUTDist: array[0..255, 0..255] of Integer;
LG_COUNT: Integer;
LG_DETAIL: Integer;
FFreeList: TList;
procedure AllocHandle;
procedure CanvasChanging(Sender: TObject);
procedure Changing(MemoryImage: Boolean);
183,28 → 113,15
function GetTopPBits: Pointer;
function GetTopPBitsReadOnly: Pointer;
procedure SetBitCount(Value: Integer);
procedure SetImage(Value: TDIBSharedImage); {$IFDEF VER9UP}inline;{$ENDIF}
procedure SetImage(Value: TDIBSharedImage);
procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
procedure SetPixel(X, Y: Integer; Value: DWORD);
procedure StartProgress(const Name: string);
procedure EndProgress;
procedure UpdateProgress(PercentY: Integer);
 
{ Added these 3 functions for New Specials Effects }
function Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function IntToByte(i: Integer): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
{ End of 3 functions for New Special Effect }
 
procedure Darkness(Amount: Integer);
function GetAlphaChannel: TDIB;
procedure SetAlphaChannel(const Value: TDIB);
function GetClientRect: TRect;
function GetRGBChannel: TDIB;
procedure SetRGBChannel(const Value: TDIB);
protected
procedure DefineProperties(Filer: TFiler); override;
procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetPalette: HPalette; override;
224,9 → 141,6
procedure Compress;
procedure Decompress;
procedure FreeHandle;
function HasAlphaChannel: Boolean;
function AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
procedure RetAlphaChannel(out oDIB: TDIB);
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure LoadFromStream(Stream: TStream); override;
233,7 → 147,7
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
procedure SaveToStream(Stream: TStream); override;
procedure SetSize(AWidth, AHeight, ABitCount: Integer); {$IFDEF VER5UP}reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
procedure SetSize(AWidth, AHeight, ABitCount: Integer);
procedure UpdatePalette;
{ Special effect }
procedure Blur(ABitCount: Integer; Radius: Integer);
241,160 → 155,6
procedure Mirror(MirrorX, MirrorY: Boolean);
procedure Negative;
 
{ Added New Special Effect }
procedure Spray(Amount: Integer);
procedure Emboss;
procedure AddMonoNoise(Amount: Integer);
procedure AddGradiantNoise(Amount: byte);
function Twist(bmp: TDIB; Amount: byte): Boolean;
function FishEye(bmp: TDIB): Boolean;
function SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
procedure Lightness(Amount: Integer);
procedure Saturation(Amount: Integer);
procedure Contrast(Amount: Integer);
procedure AddRGB(aR, aG, aB: Byte);
function Filter(Dest: TDIB; Filter: TFilter): Boolean;
procedure Sharpen(Amount: Integer);
function IntToColor(i: Integer): TBGR; {$IFDEF VER9UP}inline;{$ENDIF}
function Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
procedure SplitBlur(Amount: Integer);
procedure GaussianBlur(Bmp: TDIB; Amount: Integer);
{ End of New Special Effect }
{
New effect for TDIB
with Some Effects like AntiAlias, Contrast,
Lightness, Saturation, GaussianBlur, Mosaic,
Twist, Splitlight, Trace, Emboss, etc.
Works with 24bit color DIBs.
 
This component is based on TProEffectImage component version 1.0 by
Written By Babak Sateli (babak_sateli@yahoo.com, http://raveland.netfirms.com)
 
and modified by (c) 2004 Jaro Benes
for DelphiX use.
 
Demo was modified into DXForm with function like original
 
DISCLAIMER
This component is provided AS-IS without any warranty of any kind, either express or
implied. This component is freeware and can be used in any software product.
}
procedure DoInvert;
procedure DoAddColorNoise(Amount: Integer);
procedure DoAddMonoNoise(Amount: Integer);
procedure DoAntiAlias;
procedure DoContrast(Amount: Integer);
procedure DoFishEye(Amount: Integer);
procedure DoGrayScale;
procedure DoLightness(Amount: Integer);
procedure DoDarkness(Amount: Integer);
procedure DoSaturation(Amount: Integer);
procedure DoSplitBlur(Amount: Integer);
procedure DoGaussianBlur(Amount: Integer);
procedure DoMosaic(Size: Integer);
procedure DoTwist(Amount: Integer);
procedure DoSplitlight(Amount: Integer);
procedure DoTile(Amount: Integer);
procedure DoSpotLight(Amount: Integer; Spot: TRect);
procedure DoTrace(Amount: Integer);
procedure DoEmboss;
procedure DoSolorize(Amount: Integer);
procedure DoPosterize(Amount: Integer);
procedure DoBrightness(Amount: Integer);
procedure DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
{rotate}
procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
procedure DoColorize(ForeColor, BackColor: TColor);
{Simple explosion spoke effect}
procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
 
{Simple Mandelbrot-set drawing}
procedure DrawMandelbrot(ao, au: Integer; bo, bu: Double);
 
{Sephia effect}
procedure SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
 
{Simple blend pixel}
procedure BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
{Line in polar system}
procedure LinePolar(x, y: Integer; AngleInDegree, Length: extended;
Color: cardinal);
 
{special version Dark/Light procedure in percent}
procedure Darker(Percent: Integer);
procedure Lighter(Percent: Integer);
 
{Simple graphical crypt}
procedure EncryptDecrypt(const Key: Integer);
 
{ Standalone DXFusion }
{--- c o n F u s i o n ---}
{By Joakim Back, www.back.mine.nu}
{Huge thanks to Ilkka Tuomioja for helping out with the project.}
 
{
modified by (c) 2005 Jaro Benes for DelphiX use.
}
 
procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
{Drawing Methods.}
procedure DrawOn(Dest: TRect; DestCanvas: TCanvas;
Xsrc, Ysrc: Integer);
procedure DrawTo(SrcDIB: TDIB; X, Y, Width, Height, SourceX,
SourceY: Integer);
procedure DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor); {$IFDEF VER5UP} reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
FilterMode: TFilterMode);
procedure DrawShadows(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
Alpha: Byte);
procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer);
procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF};
Frame: Integer{$IFDEF VER4UP} = 0{$ENDIF});
procedure DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor;
FilterMode: TFilterMode);
procedure DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
procedure DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY: Integer; const Color: TColor);
procedure DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY, Alpha: Integer; const Color: TColor);
procedure DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y, Width,
Height, SourceX, SourceY: Integer);
procedure DrawAntialias(SrcDIB: TDIB);
procedure Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
procedure DrawMono(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
{One-color Filters.}
procedure FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
procedure FilterRect(X, Y, Width, Height: Integer; Color: TColor;
FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
{ Lightsource. }
procedure InitLight(Count, Detail: Integer);
procedure DrawLights(FLight: TLightArray; AmbientLight: TColor);
//
// effect for special purpose
//
procedure FadeOut(DIB2: TDIB; Step: Byte);
procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
procedure DoBlur(DIB2: TDIB);
procedure FadeIn(DIB2: TDIB; Step: Byte);
procedure FillDIB8(Color: Byte);
procedure DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
// lines
procedure AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor); {$IFDEF VER9UP} inline; {$ENDIF}
function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
procedure ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry;
iRadius: WORD);
// standard property
property BitCount: Integer read FBitCount write SetBitCount;
property BitmapInfo: PBitmapInfo read GetBitmapInfo;
property BitmapInfoSize: Integer read GetBitmapInfoSize;
414,15 → 174,8
property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
property Width: Integer read FWidth write SetWidth;
property WidthBytes: Integer read FWidthBytes;
property AlphaChannel: TDIB read GetAlphaChannel write SetAlphaChannel;
property RGBChannel: TDIB read GetRGBChannel write SetRGBChannel;
function CreateBitmapFromDIB: TBitmap;
procedure Fill(aColor: TColor);
property ClientRect: TRect read GetClientRect;
end;
 
{ TDIBitmap }
 
TDIBitmap = class(TDIB) end;
 
{ TCustomDXDIB }
482,10 → 235,10
 
TDXPaintBox = class(TCustomDXPaintBox)
published
{$IFDEF VER4UP}property Anchors; {$ENDIF}
{$IFDEF DelphiX_Spt4}property Anchors;{$ENDIF}
property AutoStretch;
property Center;
{$IFDEF VER4UP}property Constraints; {$ENDIF}
{$IFDEF DelphiX_Spt4}property Constraints;{$ENDIF}
property DIB;
property KeepAspect;
property Stretch;
508,105 → 261,34
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
{$IFDEF VER9UP}property OnMouseWheel; {$ENDIF}
{$IFDEF VER9UP}property OnResize; {$ENDIF}
{$IFDEF VER9UP}property OnCanResize; {$ENDIF}
{$IFDEF VER9UP}property OnContextPopup; {$ENDIF}
property OnStartDrag;
end;
 
const
DefaultFilterRadius: array[TFilterTypeResample] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; {$IFDEF VER9UP}inline;{$ENDIF}
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
 
function GreyscaleColorTable: TRGBQuads;
 
function RGBQuad(R, G, B: Byte): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuad(R, G, B: Byte): TRGBQuad;
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
 
function PosValue(Value: Integer): Integer;
 
type
TOC = 0..511;
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
 
{ Added Constants for TFilter Type }
const
EdgeFilter: TFilter = ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1));
StrongOutlineFilter: TFilter = ((-100, 0, 0), (0, 0, 0), (0, 0, 100));
Enhance3DFilter: TFilter = ((-100, 5, 5), (5, 5, 5), (5, 5, 100));
LinearFilter: TFilter = ((-40, -40, -40), (-40, 255, -40), (-40, -40, -40));
GranularFilter: TFilter = ((-20, 5, 20), (5, -10, 5), (100, 5, -100));
SharpFilter: TFilter = ((-2, -2, -2), (-2, 20, -2), (-2, -2, -2));
{ End of constants }
 
{ Added Constants for DXFusion Type }
const
{ 3x3 Matrix Presets. }
msEmboss: TMatrixSetting = (-1, -1, 0, -1, 6, 1, 0, 1, 1, 6);
msHardEmboss: TMatrixSetting = (-4, -2, -1, -2, 10, 2, -1, 2, 4, 8);
msBlur: TMatrixSetting = (1, 2, 1, 2, 4, 2, 1, 2, 1, 16);
msSharpen: TMatrixSetting = (-1, -1, -1, -1, 15, -1, -1, -1, -1, 7);
msEdgeDetect: TMatrixSetting = (-1, -1, -1, -1, 8, -1, -1, -1, -1, 1);
 
{Proportionaly scale of size, for recountin image sizes}
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single; {$IFDEF VER9UP}inline;{$ENDIF}
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}
 
implementation
 
uses DXConsts, {$IFDEF PNG_GRAPHICS}pngimage,{$ENDIF} jpeg;
uses DXConsts;
 
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
var
XScale, YScale: Single;
begin
XScale := 1;
YScale := 1;
if TargetWidth < SourceWidth then
XScale := TargetWidth / SourceWidth;
if TargetHeight < SourceHeight then
YScale := TargetHeight / SourceHeight;
Result := XScale;
if YScale < Result then
Result := YScale;
end;
 
{$IFNDEF VER4UP}
function Max(B1, B2: Integer): Integer;
begin
if B1 >= B2 then Result := B1 else Result := B2;
end;
 
function Min(B1, B2: Integer): Integer;
begin
if B1 <= B2 then Result := B1 else Result := B2;
end;
{$ENDIF}
 
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
Result := sin(((c * 360) / 511) * Pi / 180);
end;
 
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
Result := cos(((c * 360) / 511) * Pi / 180);
end;
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
begin
Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
623,7 → 305,9
Result.BShift := 8 - BBitCount;
end;
 
function GetBitCount(b: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
 
function GetBitCount(b: Integer): Integer;
var
i: Integer;
begin
638,7 → 322,6
end;
end;
 
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
begin
Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
GetBitCount(BBitMask));
669,7 → 352,7
with PixelFormat do
begin
Result := (Color and RBitMask) shr RShift;
Result := Result or (Result shr RBitCount2);
Result := Result or (Result shr RBitCount);
end;
end;
 
678,7 → 361,7
with PixelFormat do
begin
Result := (Color and GBitMask) shr GShift;
Result := Result or (Result shr GBitCount2);
Result := Result or (Result shr GBitCount);
end;
end;
 
687,7 → 370,7
with PixelFormat do
begin
Result := (Color and BBitMask) shl BShift;
Result := Result or (Result shr BBitCount2);
Result := Result or (Result shr BBitCount);
end;
end;
 
764,8 → 447,6
RBitMask, GBitMask, BBitMask: DWORD;
end;
 
{ TPaletteItem }
 
TPaletteItem = class(TCollectionItem)
private
ID: Integer;
775,11 → 456,9
ColorTableCount: Integer;
destructor Destroy; override;
procedure AddRef;
procedure Release; {$IFDEF VER17UP}reintroduce;{$ENDIF}
procedure Release;
end;
 
{ TPaletteManager }
 
TPaletteManager = class
private
FList: TCollection;
789,8 → 468,6
procedure DeletePalette(var Palette: HPalette);
end;
 
{ TPaletteItem }
 
destructor TPaletteItem.Destroy;
begin
DeleteObject(Palette);
808,8 → 485,6
if RefCount <= 0 then Free;
end;
 
{ TPaletteManager }
 
constructor TPaletteManager.Create;
begin
inherited Create;
902,8 → 577,6
Result := FPaletteManager;
end;
 
{ TDIBSharedImage }
 
constructor TDIBSharedImage.Create;
begin
inherited Create;
919,10 → 592,8
InfoOfs: Integer;
UsePixelFormat: Boolean;
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
 
{ Pixel format check }
case ABitCount of
1: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
931,19 → 602,16
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
8: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
16:
begin
16: begin
if not (((PixelFormat.RBitMask = $7C00) and (PixelFormat.GBitMask = $03E0) and (PixelFormat.BBitMask = $001F)) or
((PixelFormat.RBitMask = $F800) and (PixelFormat.GBitMask = $07E0) and (PixelFormat.BBitMask = $001F))) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
24:
begin
24: begin
if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
32:
begin
32: begin
if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
1028,8 → 696,7
FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
if FPBits = nil then
OutOfMemoryError;
end
else
end else
begin
FDC := CreateCompatibleDC(0);
 
1046,17 → 713,11
 
procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
if Source = nil then Exit; //no source
if Source.FSize = 0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
FMemoryImage := MemoryImage;
end
else
end else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
1065,8 → 726,7
FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
end
else
end else
begin
Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
end;
1129,8 → 789,7
 
AllocByte^ := B1;
AllocByte^ := B2;
end
else
end else
if (Source.FWidth - x > 5) and ((GetPixel(x) <> GetPixel(x + 2)) or (GetPixel(x + 1) <> GetPixel(x + 3))) and
((GetPixel(x + 2) = GetPixel(x + 4)) and (GetPixel(x + 3) = GetPixel(x + 5))) then
begin
1138,8 → 797,7
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
Inc(x, 2);
end
else
end else
begin
if (Source.FWidth - x < 4) then
begin
1157,8 → 815,7
AllocByte^ := GetPixel(x) shl 4;
Inc(x);
end;
end
else
end else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
1247,8 → 904,7
 
AllocByte^ := B1;
AllocByte^ := B2;
end
else
end else
if (Source.FWidth - x > 2) and (Src^ <> PByte(Integer(Src) + 1)^) and (PByte(Integer(Src) + 1)^ = PByte(Integer(Src) + 2)^) then
begin
{ Encoding mode }
1255,8 → 911,7
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end
else
end else
begin
if (Source.FWidth - x < 4) then
begin
1269,15 → 924,13
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x, 2);
end
else
end else
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end;
end
else
end else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
1326,8 → 979,7
begin
if Source.FCompressed then
Duplicate(Source, Source.FMemoryImage)
else
begin
else begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, True, True);
case FBitmapInfo.bmiHeader.biCompression of
1378,8 → 1030,7
if i and 1 = 0 then
begin
C := Src^; Inc(Src);
end
else
end else
begin
C := C shl 4;
end;
1393,8 → 1044,7
Inc(X);
end;
end;
end
else
end else
begin
{ Encoding mode }
Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
1451,8 → 1101,7
{ Absolute mode }
Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
end;
end
else
end else
begin
{ Encoding mode }
FillChar(Dest^, B1, B2); Inc(Dest, B1);
1466,8 → 1115,7
begin
if not Source.FCompressed then
Duplicate(Source, MemoryImage)
else
begin
else begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
case Source.FBitmapInfo.bmiHeader.biCompression of
1488,7 → 1136,6
procedure LoadRLE4;
begin
FSize := BI.biSizeImage;
//GetMem(FPBits, FSize);
FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
FBitmapInfo.bmiHeader.biSizeImage := FSize;
Stream.ReadBuffer(FPBits^, FSize);
1497,7 → 1144,6
procedure LoadRLE8;
begin
FSize := BI.biSizeImage;
//GetMem(FPBits, FSize);
FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
FBitmapInfo.bmiHeader.biSizeImage := FSize;
Stream.ReadBuffer(FPBits^, FSize);
1511,8 → 1157,7
begin
for y := 0 to Abs(BI.biHeight) - 1 do
Stream.ReadBuffer(Pointer(Integer(FTopPBits) + y * FNextLine)^, FWidthBytes);
end
else
end else
begin
Stream.ReadBuffer(FPBits^, FSize);
end;
1525,17 → 1170,12
AColorTable: TRGBQuads;
APixelFormat: TDIBPixelFormat;
begin
if not Assigned(Stream) then Exit;
{ Header size reading }
i := Stream.Read(BI.biSize, 4);
 
if i = 0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
Exit;
end;
if i <> 4 then
1576,8 → 1216,7
Stream.ReadBuffer(Localpf, SizeOf(Localpf));
with Localpf do
APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
end
else
end else
begin
if BI.biBitCount = 16 then
APixelFormat := MakeDIBPixelFormat(5, 5, 5)
1604,14 → 1243,13
with BCRGB[i] do
AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
end;
end
else
end else
begin
{ Windows type }
Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad) * PalCount);
end;
 
{ DIB compilation }
{ DIB ì¬ }
NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);
 
1632,9 → 1270,7
begin
if FOldHandle <> 0 then SelectObject(FDC, FOldHandle);
DeleteObject(FHandle);
end
else
// GlobalFree(THandle(FPBits));
end else
begin
if FPBits <> nil then
GlobalFreePtr(FPBits);
1697,26 → 1333,12
begin
inherited Create;
SetImage(EmptyDIBImage);
 
FFreeList := TList.Create;
end;
 
destructor TDIB.Destroy;
var
D: TDIB;
begin
SetImage(EmptyDIBImage);
FCanvas.Free;
 
while FFreeList.Count > 0 do
try
D := TDIB(FFreeList[0]);
FFreeList.Remove(D);
D.Free;
except
end;
FFreeList.Free;
 
inherited Destroy;
end;
 
1750,14 → 1372,12
if DIBSectionRec^.dsBm.bmBitsPixel >= 24 then
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end
else
end else
if DIBSectionRec^.dsBm.bmBitsPixel > 8 then
begin
PixelFormat := MakeDIBPixelFormatMask(DIBSectionRec^.dsBitfields[0], //correct I.Ceneff, thanks
PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0],
DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
end
else
end else
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;
1773,64 → 1393,14
end;
 
procedure AssignGraphic(Source: TGraphic);
{$IFDEF PNG_GRAPHICS}
var
alpha: TDIB;
png: {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF};
i, j: Integer;
q: pByteArray;
{$ENDIF}
begin
{$IFDEF PNG_GRAPHICS}
if Source is {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF} then
begin
alpha := TDIB.Create;
try
{png image}
png := {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF}.Create;
try
png.Assign(Source);
if png.TransparencyMode = ptmPartial then
begin
Alpha.SetSize(png.Width, png.Height, 8);
{separate alpha}
for i := 0 to png.Height - 1 do
begin
q := png.AlphaScanline[i];
for j := 0 to png.Width - 1 do
alpha.Pixels[j,i] := q[j];
end;
end;
SetSize(png.Width, png.Height, 32);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, png);
Transparent := png.Transparent;
finally
png.Free;
end;
if not alpha.Empty then
AssignAlphaChannel(alpha);
finally
alpha.Free;
end;
end
else
{$ENDIF}
if Source is TBitmap then
AssignBitmap(TBitmap(Source))
else
begin
SetSize(Source.Width, Source.Height, 32);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, Source);
Transparent := Source.Transparent;
if not HasAlphaChannel then
begin
SetSize(Source.Width, Source.Height, 24);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, Source);
Transparent := Source.Transparent;
end
end;
end;
 
1855,7 → 1425,7
inherited Assign(Source);
end;
 
procedure TDIB.Draw(ACanvas: TCanvas; const ARect: TRect);
procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect);
var
OldPalette: HPalette;
OldMode: Integer;
1866,8 → 1436,7
begin
OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
RealizePalette(ACanvas.Handle);
end
else
end else
OldPalette := 0;
try
OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
1875,18 → 1444,14
GdiFlush;
if FImage.FMemoryImage then
begin
with ARect do
with Rect do
StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode);
end else
begin
if StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
0, 0, Self.Width, Self.Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS, ACanvas.CopyMode) = 0 then
MessageBeep(1);
end;
end
else
begin
with ARect do
with Rect do
StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
FImage.FDC, 0, 0, Self.Width, Self.Height, ACanvas.CopyMode);
FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode);
end;
finally
SetStretchBltMode(ACanvas.Handle, OldMode);
1992,161 → 1557,6
end;
end;
 
type
PRGBA = ^TRGBA;
TRGBA = array[0..0] of Windows.TRGBQuad;
 
function TDIB.HasAlphaChannel: Boolean;
{give that DIB contain the alphachannel}
var
p: PRGBA;
X, Y: Integer;
begin
Result := True;
if BitCount = 32 then
for Y := 0 to Height - 1 do
begin
p := ScanLine[Y];
for X := 0 to Width - 1 do
begin
if p[X].rgbReserved <> $0 then Exit;
end
end;
Result := False;
end;
 
function TDIB.AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
{copy alphachannel from other DIB or add from DIB8}
var
p32_0, p32_1: PRGBA;
p24: Pointer;
pB: PArrayByte;
X, Y: Integer;
tmpDIB, qAlpha: TDIB;
begin
Result := False;
if GetEmpty then Exit;
{Alphachannel can be copy into 32bit DIB only!}
if BitCount <> 32 then
begin
tmpDIB := TDIB.Create;
try
tmpDIB.Assign(Self);
Clear;
SetSize(tmpDIB.Width, tmpDIB.Height, 32);
Canvas.Draw(0, 0, tmpDIB);
finally
tmpDIB.Free;
end;
end;
qAlpha := TDIB.Create;
try
if not Assigned(Alpha) then Exit;
if ForceResize then
begin
{create temp}
tmpDIB := TDIB.Create;
try
{picture}
tmpDIB.Assign(ALPHA);
{resample size}
tmpDIB.DoResample(Width, Height, ftrBSpline);
{convert to greyscale}
tmpDIB.Greyscale(8);
{return picture to qAlpha}
qAlpha.Assign(tmpDIB);
finally
tmpDIB.Free;
end;
end
else
{Must be the same size!}
if not ((Width = ALPHA.Width) and (Height = ALPHA.Height)) then Exit
else qAlpha.Assign(ALPHA);
{It works now with qAlpha only}
case qAlpha.BitCount of
24:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
p24 := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do with PBGR(p24)^ do
begin
p32_0[X].rgbReserved := Round(0.30 * R + 0.59 * G + 0.11 * B);
end
end;
end;
32:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
p32_1 := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
p32_0[X].rgbReserved := p32_1[X].rgbReserved;
end
end;
end;
8:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
pB := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
p32_0[X].rgbReserved := pB[X];
end
end;
end;
1:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
pB := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
if pB[X] = 0 then
p32_0[X].rgbReserved := $FF
else
p32_0[X].rgbReserved := 0
end
end;
end;
else
Exit;
end;
Result := True;
finally
qAlpha.Free;
end;
end;
 
procedure TDIB.RetAlphaChannel(out oDIB: TDIB);
{Store alphachannel information into DIB8}
var
p0: PRGBA;
pB: PArrayByte;
X, Y: Integer;
begin
oDIB := nil;
if not HasAlphaChannel then exit;
oDIB := TDIB.Create;
oDIB.SetSize(Width, Height, 8);
for Y := 0 to Height - 1 do
begin
p0 := ScanLine[Y];
pB := oDIB.ScanLine[Y];
for X := 0 to Width - 1 do
begin
pB[X] := p0[X].rgbReserved;
end
end;
end;
 
function TDIB.GetBitmapInfo: PBitmapInfo;
begin
Result := FImage.FBitmapInfo;
2273,7 → 1683,7
begin
case FBitCount of
1: Result := (PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
4: Result := ((PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]);
4 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
8: Result := PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X];
16: Result := PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X];
24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
2283,17 → 1693,6
end;
end;
 
function TDIB.GetRGBChannel: TDIB;
{Store RGB channel information into DIB24}
begin
Result := nil;
if Self.Empty then Exit;
Result := TDIB.Create;
Result.SetSize(Width, Height, 24);
Self.DrawOn(Bounds(0,0, Self.Width, Self.Height), Result.Canvas, 0, 0);
FFreeList.Add(Result);
end;
 
procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
var
P: PByte;
2308,8 → 1707,8
P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
end;
4: begin
P := (@PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3]);
P^ := ((P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]));
P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
P^ := (P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]);
end;
8: PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
16: PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
2324,23 → 1723,6
end;
end;
 
procedure TDIB.SetRGBChannel(const Value: TDIB);
var
alpha: TDIB;
begin
if Self.HasAlphaChannel then
try
RetAlphaChannel(alpha);
Self.SetSize(Value.Width, Value.Height, 32);
Value.DrawOn(Bounds(0,0,Value.Width, Value.Height), Self.Canvas, 0, 0);
Self.AssignAlphaChannel(alpha, True);
finally
alpha.Free;
end
else
Self.Assign(Value);
end;
 
procedure TDIB.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
2349,8 → 1731,6
end;
 
type
{ TGlobalMemoryStream }
 
TGlobalMemoryStream = class(TMemoryStream)
private
FHandle: THandle;
2393,7 → 1773,6
var
BF: TBitmapFileHeader;
i: Integer;
ImageJPEG: TJPEGImage;
begin
{ File header reading }
i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
2401,30 → 1780,6
if i <> SizeOf(TBitmapFileHeader) then
raise EInvalidGraphic.Create(SInvalidDIB);
 
{ Is the head jpeg ?}
 
if BF.bfType = $D8FF then
begin
ImageJPEG := TJPEGImage.Create;
try
try
Stream.Position := 0;
ImageJPEG.LoadFromStream(Stream);
except
on EInvalidGraphic do ImageJPEG := nil;
end;
if ImageJPEG <> nil then
begin
{set size and bitcount in natural units of jpeg}
SetSize(ImageJPEG.Width, ImageJPEG.Height, 24);
Canvas.Draw(0, 0, ImageJPEG);
Exit
end;
finally
ImageJPEG.Free;
end;
end
else
{ Is the head 'BM'? }
if BF.bfType <> BitmapFileType then
raise EInvalidGraphic.Create(SInvalidDIB);
2509,8 → 1864,7
if Empty then
begin
SetSize(Max(Width, 1), Max(Height, 1), Value)
end
else
end else
begin
ConvertBitCount(Value);
end;
2677,16 → 2031,13
for x := 0 to Width - 1 do
begin
case Temp.BitCount of
1:
begin
1 : begin
i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
end;
4:
begin
4 : begin
i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
end;
8:
begin
8 : begin
i := PByte(SrcP)^;
Inc(PByte(SrcP));
end;
2693,18 → 2044,15
end;
 
case BitCount of
1:
begin
1 : begin
P := @PArrayByte(DestP)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
end;
4:
begin
4 : begin
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
end;
8:
begin
8 : begin
PByte(DestP)^ := i;
Inc(PByte(DestP));
end;
2731,8 → 2079,7
for x := 0 to Width - 1 do
begin
case Temp.BitCount of
1:
begin
1 : begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
begin
cR := rgbRed;
2740,8 → 2087,7
cB := rgbBlue;
end;
end;
4:
begin
4 : begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
begin
cR := rgbRed;
2749,8 → 2095,7
cB := rgbBlue;
end;
end;
8:
begin
8 : begin
with Temp.ColorTable[PByte(SrcP)^] do
begin
cR := rgbRed;
2759,13 → 2104,11
end;
Inc(PByte(SrcP));
end;
16:
begin
16: begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
Inc(PWord(SrcP));
end;
24:
begin
24: begin
with PBGR(SrcP)^ do
begin
cR := R;
2775,8 → 2118,7
 
Inc(PBGR(SrcP));
end;
32:
begin
32: begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
Inc(PDWORD(SrcP));
end;
2783,13 → 2125,11
end;
 
case BitCount of
16:
begin
16: begin
PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PWord(DestP));
end;
24:
begin
24: begin
with PBGR(DestP)^ do
begin
R := cR;
2798,8 → 2138,7
end;
Inc(PBGR(DestP));
end;
32:
begin
32: begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PDWORD(DestP));
end;
2824,8 → 2163,7
if Temp.BitCount <= BitCount then
begin
PaletteToPalette_Inc;
end
else
end else
begin
case BitCount of
1: begin
2839,14 → 2177,12
 
Canvas.Draw(0, 0, Temp);
end;
end
else
end else
if (Temp.BitCount <= 8) and (BitCount > 8) then
begin
{ The image is converted from the palette color image into the rgb color image. }
PaletteToRGB_or_RGBToRGB;
end
else
end else
if (Temp.BitCount > 8) and (BitCount <= 8) then
begin
{ The image is converted from the rgb color image into the palette color image. }
2861,8 → 2197,7
UpdatePalette;
 
Canvas.Draw(0, 0, Temp);
end
else
end else
if (Temp.BitCount > 8) and (BitCount > 8) then
begin
{ The image is converted from the rgb color image into the rgb color image. }
2916,211 → 2251,6
Inc(FProgressY);
end;
 
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
begin
if Empty then Exit;
if (not MirrorX) and (not MirrorY) then Exit;
 
if (not MirrorX) and (MirrorY) then
begin
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y := 0 to Height shr 1 - 1 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height - y - 1];
 
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
 
UpdateProgress(y * 2);
end;
finally
EndProgress;
end;
finally
FreeMem(TempBuf, WidthBytes);
end;
end
else
if (MirrorX) and (not MirrorY) then
begin
Width2 := Width shr 1;
 
StartProgress('Mirror');
try
for y := 0 to Height - 1 do
begin
P1 := ScanLine[y];
 
case BitCount of
1:
begin
for x := 0 to Width2 - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, y];
Pixels[Width - x - 1, y] := c;
end;
end;
4:
begin
for x := 0 to Width2 - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, y];
Pixels[Width - x - 1, y] := c;
end;
end;
8:
begin
P2 := Pointer(Integer(P1) + Width - 1);
for x := 0 to Width2 - 1 do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
end;
16:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 2);
for x := 0 to Width2 - 1 do
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
end;
24:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 3);
for x := 0 to Width2 - 1 do
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
32:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 4);
for x := 0 to Width2 - 1 do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
end;
 
UpdateProgress(y);
end;
finally
EndProgress;
end;
end
else
if (MirrorX) and (MirrorY) then
begin
StartProgress('Mirror');
try
for y := 0 to Height shr 1 - 1 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height - y - 1];
 
case BitCount of
1:
begin
for x := 0 to Width - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
Pixels[Width - x - 1, Height - y - 1] := c;
end;
end;
4:
begin
for x := 0 to Width - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
Pixels[Width - x - 1, Height - y - 1] := c;
end;
end;
8:
begin
P2 := Pointer(Integer(P2) + Width - 1);
for x := 0 to Width - 1 do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
end;
16:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 2);
for x := 0 to Width - 1 do
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
end;
24:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 3);
for x := 0 to Width - 1 do
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
32:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 4);
for x := 0 to Width - 1 do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
end;
 
UpdateProgress(y * 2);
end;
finally
EndProgress;
end;
end;
end;
 
procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
type
TAve = record
3140,8 → 2270,7
R, G, B: Byte;
begin
case Temp.BitCount of
1:
begin
1 : begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3156,8 → 2285,7
Inc(AveP);
end;
end;
4:
begin
4 : begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3172,8 → 2300,7
Inc(AveP);
end;
end;
8:
begin
8 : begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3189,8 → 2316,7
Inc(AveP);
end;
end;
16:
begin
16: begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3207,8 → 2333,7
Inc(AveP);
end;
end;
24:
begin
24: begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3224,8 → 2349,7
Inc(AveP);
end;
end;
32:
begin
32: begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3253,8 → 2377,7
R, G, B: Byte;
begin
case Temp.BitCount of
1:
begin
1 : begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3269,8 → 2392,7
Inc(AveP);
end;
end;
4:
begin
4 : begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3285,8 → 2407,7
Inc(AveP);
end;
end;
8:
begin
8 : begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3302,8 → 2423,7
Inc(AveP);
end;
end;
16:
begin
16: begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3320,8 → 2440,7
Inc(AveP);
end;
end;
24:
begin
24: begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3337,8 → 2456,7
Inc(AveP);
end;
end;
32:
begin
32: begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
3461,32 → 2579,27
 
{ The average is written. }
case BitCount of
1:
begin
1 : begin
P := @PArrayByte(DestP)[X shr 3];
with Ave do
P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR + cG + cB) div c) div 3 > 127)) shl Shift1[X and 7]);
end;
4:
begin
4 : begin
P := @PArrayByte(DestP)[X shr 1];
with Ave do
P^ := (P^ and Mask4n[X and 1]) or (((((cR + cG + cB) div c) div 3) shr 4) shl Shift4[X and 1]);
end;
8:
begin
8 : begin
with Ave do
PByte(DestP)^ := ((cR + cG + cB) div c) div 3;
Inc(PByte(DestP));
end;
16:
begin
16: begin
with Ave do
PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PWORD(DestP));
end;
24:
begin
24: begin
with PBGR(DestP)^, Ave do
begin
R := cR div c;
3495,8 → 2608,7
end;
Inc(PBGR(DestP));
end;
32:
begin
32: begin
with Ave do
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PDWORD(DestP));
3546,64 → 2658,6
end;
end;
 
procedure TDIB.Negative;
var
i, i2: Integer;
P: Pointer;
begin
if Empty then exit;
 
if BitCount <= 8 then
begin
for i := 0 to 255 do
with ColorTable[i] do
begin
rgbRed := 255 - rgbRed;
rgbGreen := 255 - rgbGreen;
rgbBlue := 255 - rgbBlue;
end;
UpdatePalette;
end else
begin
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
 
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
 
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
 
mov ecx,edx
shr ecx,2
add eax,ecx*4
 
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@byte_skip
 
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
 
@@byte_skip:
end;
end;
end;
 
procedure TDIB.Greyscale(ABitCount: Integer);
var
YTblR, YTblG, YTblB: array[0..255] of Byte;
3614,7 → 2668,7
DestP, SrcP: Pointer;
P: PByte;
begin
if Empty then Exit;
if Empty then exit;
 
Temp := TDIB.Create;
try
3652,36 → 2706,30
for x := 0 to Width - 1 do
begin
case Temp.BitCount of
1:
begin
1 : begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
end;
4:
begin
4 : begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
end;
8:
begin
8 : begin
with Temp.ColorTable[PByte(SrcP)^] do
c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
Inc(PByte(SrcP));
end;
16:
begin
16: begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
c := YTblR[R] + YTblR[G] + YTblR[B];
Inc(PWord(SrcP));
end;
24:
begin
24: begin
with PBGR(SrcP)^ do
c := YTblR[R] + YTblG[G] + YTblB[B];
Inc(PBGR(SrcP));
end;
32:
begin
32: begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
c := YTblR[R] + YTblR[G] + YTblR[B];
Inc(PDWORD(SrcP));
3689,28 → 2737,23
end;
 
case BitCount of
1:
begin
1 : begin
P := @PArrayByte(DestP)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c > 127)) shl Shift1[X and 7]);
end;
4:
begin
4 : begin
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]);
end;
8:
begin
8 : begin
PByte(DestP)^ := c;
Inc(PByte(DestP));
end;
16:
begin
16: begin
PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PWord(DestP));
end;
24:
begin
24: begin
with PBGR(DestP)^ do
begin
R := c;
3719,8 → 2762,7
end;
Inc(PBGR(DestP));
end;
32:
begin
32: begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PDWORD(DestP));
end;
3737,1574 → 2779,253
end;
end;
 
//--------------------------------------------------------------------------------------------------
// Version : 0.1 - 26/06/2000 //
// Version : 0.2 - 04/07/2000 //
// At someone's request, i have added 3 news effects : //
// 1 - Rotate //
// 2 - SplitBlur //
// 3 - GaussianBlur //
//--------------------------------------------------------------------------------------------------
// - NEW SPECIAL EFFECT - (English) //
//--------------------------------------------------------------------------------------------------
// At the start, my idea was to create a component derived from TCustomDXDraw. Unfortunately, //
// it's impossible to run a graphic component (derived from TCustomDXDraw) in a conception's //
// mode (i don't success, but perhaps, somebody know how doing ! In that case, please help me !!!)//
// Then, i'm used the DIB's unit for my work, but this unit is poor in special effect. Knowing a //
// library with more effect, i'm undertaked to import this library in DIB's unit. You can see the //
// FastLib library at : //
// //
// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
// //
// It was very difficult, because implementation's graphic was very different that DIB's unit. //
// Sometimes, i'm deserted the possibility of original effect, particularly in conversion of DIB //
// whith 256, 16 and 2 colors. If someone can implement this fonctionnality, thanks to tell me //
// how this miracle is possible !!! //
// All these procedures are translated and adapted by : //
// //
// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
// //
// IMPORTANT : These procedures don't modify the DIB's unit structure //
// Nota Bene : I don't implement these type of graphics (32 and 16 bit per pixels), //
// for one reason : I haven't bitmaps of this type !!! //
//--------------------------------------------------------------------------------------------------
//--------------------------------------------------------------------------------------------------
// - NOUVEAUX EFFETS SPECIAUX - (Français) //
//--------------------------------------------------------------------------------------------------
// Au commencement, mon idée était de dériver un composant de TCustomDXDraw. Malheureusement, //
// c'est impossible de faire fonctionner un composant graphique (derivé de TCustomDXDraw) en mode //
// conception (je n'y suis pas parvenu, mais peut-être, que quelqu'un sait comment faire ! Dans //
// ce cas, vous seriez aimable de m'aider !!!) //
// Alors, j'ai utilisé l'unité DIB pour mon travail,mais celle-ci est pauvre en effet spéciaux. //
// Connaissant une librairie avec beaucoup plus d'effets spéciaux, j'ai entrepris d'importer //
// cette librairie dans l'unité DIB. Vous pouvez voir la librairie FastLib à : //
// //
// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
// //
// C'était très difficile car l'implémentation graphique est très différente de l'unité DIB. //
// Parfois, j'ai abandonné les possibilités de l'effet original, particulièrement dans la //
// conversion des DIB avec 256, 16 et 2 couleurs. Si quelqu'un arrive à implémenter ces //
// fonctionnalités, merci de me dire comment ce miracle est possible !!! //
// Toutes ces procédures ont été traduites et adaptées par: //
// //
// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
// //
// IMPORTANT : Ces procédures ne modifient pas la structure de l'unité DIB //
// Nota Bene : Je n'ai pas implémenté ces types de graphiques (32 et 16 bit par pixels), //
// pour une raison : je n'ai pas de bitmap de ce type !!! //
//--------------------------------------------------------------------------------------------------
 
function TDIB.IntToColor(i: Integer): TBGR;
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
begin
Result.b := i shr 16;
Result.g := i shr 8;
Result.r := i;
end;
if Empty then exit;
if (not MirrorX) and (not MirrorY) then Exit;
 
function TDIB.Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer;
if (not MirrorX) and (MirrorY) then
begin
if iMark then
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
begin
if iValue < iMin then
Result := iMin
else
if iValue > iMax then
Result := iMax
else
Result := iValue;
end
else
begin
if iValue < iMin then
Result := iMin
else
if iValue > iMax then
Result := iMin
else
Result := iValue;
end;
end;
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
 
procedure TDIB.Contrast(Amount: Integer);
var
x, y: Integer;
Table1: array[0..255] of Byte;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
D := nil;
S := nil;
Temp1 := nil;
for i := 0 to 126 do
begin
y := (Abs(128 - i) * Amount) div 256;
Table1[i] := IntToByte(i - y);
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
 
UpdateProgress(y*2);
end;
for i := 127 to 255 do
begin
y := (Abs(128 - i) * Amount) div 256;
Table1[i] := IntToByte(i + y);
finally
EndProgress;
end;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(Table1[rgbRed]);
rgbGreen := IntToByte(Table1[rgbGreen]);
rgbBlue := IntToByte(Table1[rgbBlue]);
finally
FreeMem(TempBuf, WidthBytes);
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
end else if (MirrorX) and (not MirrorY) then
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ;
24:
begin
PBGR(D)^.B := Table1[PBGR(D)^.B];
PBGR(D)^.G := Table1[PBGR(D)^.G];
PBGR(D)^.R := Table1[PBGR(D)^.R];
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
Inc(PWord(D));
end;
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
Width2 := Width shr 1;
 
procedure TDIB.Saturation(Amount: Integer);
var
Grays: array[0..767] of Integer;
Alpha: array[0..255] of Word;
Gray, x, y: Integer;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
StartProgress('Mirror');
try
for y:=0 to Height-1 do
begin
D := nil;
S := nil;
Temp1 := nil;
for i := 0 to 255 do
Alpha[i] := (i * Amount) shr 8;
x := 0;
for i := 0 to 255 do
begin
Gray := i - Alpha[i];
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
end;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
Gray := Grays[rgbRed + rgbGreen + rgbBlue];
rgbRed := IntToByte(Gray + Alpha[rgbRed]);
rgbGreen := IntToByte(Gray + Alpha[rgbGreen]);
rgbBlue := IntToByte(Gray + Alpha[rgbBlue]);
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ;
24:
begin
Gray := Grays[PBGR(D)^.R + PBGR(D)^.G + PBGR(D)^.B];
PBGR(D)^.B := IntToByte(Gray + Alpha[PBGR(D)^.B]);
PBGR(D)^.G := IntToByte(Gray + Alpha[PBGR(D)^.G]);
PBGR(D)^.R := IntToByte(Gray + Alpha[PBGR(D)^.R]);
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := IntToByte(Gray + Alpha[B]) + IntToByte(Gray + Alpha[G]) +
IntToByte(Gray + Alpha[R]);
Inc(PWord(D));
end;
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
P1 := ScanLine[y];
 
procedure TDIB.Lightness(Amount: Integer);
var
x, y: Integer;
Table1: array[0..255] of Byte;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
D := nil;
S := nil;
Temp1 := nil;
if Amount < 0 then
begin
Amount := -Amount;
for i := 0 to 255 do
Table1[i] := IntToByte(i - ((Amount * i) shr 8));
end
else
for i := 0 to 255 do
Table1[i] := IntToByte(i + ((Amount * (i xor 255)) shr 8));
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
1 : begin
for x:=0 to Width2-1 do
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(Table1[rgbRed]);
rgbGreen := IntToByte(Table1[rgbGreen]);
rgbBlue := IntToByte(Table1[rgbBlue]);
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, y];
Pixels[Width-x-1, y] := c;
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
4 : begin
for x:=0 to Width2-1 do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, y];
Pixels[Width-x-1, y] := c;
end;
else
end;
for x := 0 to Pred(Width) do
8 : begin
P2 := Pointer(Integer(P1)+Width-1);
for x:=0 to Width2-1 do
begin
case BitCount of
32: ;
24:
begin
PBGR(D)^.B := Table1[PBGR(D)^.B];
PBGR(D)^.G := Table1[PBGR(D)^.G];
PBGR(D)^.R := Table1[PBGR(D)^.R];
Inc(PBGR(D));
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
Inc(PWord(D));
end;
8:
16: begin
P2 := Pointer(Integer(P1)+(Width-1)*2);
for x:=0 to Width2-1 do
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
procedure TDIB.AddRGB(aR, aG, aB: Byte);
var
Table: array[0..255] of TBGR;
x, y: Integer;
i: Byte;
D: pointer;
P: PByte;
color: DWORD;
Temp1: TDIB;
R, G, B: Byte;
24: begin
P2 := Pointer(Integer(P1)+(Width-1)*3);
for x:=0 to Width2-1 do
begin
color := 0;
D := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24, 16:
begin
for i := 0 to 255 do
begin
Table[i].b := IntToByte(i + aB);
Table[i].g := IntToByte(i + aG);
Table[i].r := IntToByte(i + aR);
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
8, 4:
32: begin
P2 := Pointer(Integer(P1)+(Width-1)*4);
for x:=0 to Width2-1 do
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(rgbRed + aR);
rgbGreen := IntToByte(rgbGreen + aG);
rgbBlue := IntToByte(rgbBlue + aB);
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ; // I haven't bitmap of this type ! Sorry
24:
begin
PBGR(D)^.B := Table[PBGR(D)^.B].b;
PBGR(D)^.G := Table[PBGR(D)^.G].g;
PBGR(D)^.R := Table[PBGR(D)^.R].r;
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table[R].r + Table[G].g + Table[B].b;
Inc(PWord(D));
end;
8:
begin
Inc(PByte(D));
end;
4:
begin
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
function TDIB.Filter(Dest: TDIB; Filter: TFilter): Boolean;
var
Sum, r, g, b, x, y: Integer;
a, i, j: byte;
tmp: TBGR;
Col: PBGR;
D: Pointer;
begin
Result := True;
Sum := Filter[0, 0] + Filter[1, 0] + Filter[2, 0] +
Filter[0, 1] + Filter[1, 1] + Filter[2, 1] +
Filter[0, 2] + Filter[1, 2] + Filter[2, 2];
if Sum = 0 then
Sum := 1;
Col := PBits;
for y := 0 to Pred(Height) do
begin
D := Dest.ScanLine[y];
for x := 0 to Pred(Width) do
begin
r := 0; g := 0; b := 0;
case BitCount of
32, 16, 4, 1:
begin
Result := False;
Exit;
UpdateProgress(y);
end;
24:
begin
for i := 0 to 2 do
begin
for j := 0 to 2 do
begin
Tmp := IntToColor(Pixels[Interval(0, Pred(Width), x + Pred(i), True),
Interval(0, Pred(Height), y + Pred(j), True)]);
Inc(b, Filter[i, j] * Tmp.b);
Inc(g, Filter[i, j] * Tmp.g);
Inc(r, Filter[i, j] * Tmp.r);
finally
EndProgress;
end;
end;
Col.b := IntToByte(b div Sum);
Col.g := IntToByte(g div Sum);
Col.r := IntToByte(r div Sum);
Dest.Pixels[x, y] := rgb(Col.r, Col.g, Col.b);
end;
8:
end else if (MirrorX) and (MirrorY) then
begin
for i := 0 to 2 do
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
begin
for j := 0 to 2 do
begin
a := (Pixels[Interval(0, Pred(Width), x + Pred(i), True),
Interval(0, Pred(Height), y + Pred(j), True)]);
tmp.r := ColorTable[a].rgbRed;
tmp.g := ColorTable[a].rgbGreen;
tmp.b := ColorTable[a].rgbBlue;
Inc(b, Filter[i, j] * Tmp.b);
Inc(g, Filter[i, j] * Tmp.g);
Inc(r, Filter[i, j] * Tmp.r);
end;
end;
Col.b := IntToByte(b div Sum);
Col.g := IntToByte(g div Sum);
Col.r := IntToByte(r div Sum);
PByte(D)^ := rgb(Col.r, Col.g, Col.b);
Inc(PByte(D));
end;
end;
end;
end;
end;
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
 
procedure TDIB.Spray(Amount: Integer);
var
value, x, y: Integer;
D: Pointer;
color: DWORD;
P: PByte;
begin
for y := Pred(Height) downto 0 do
begin
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
value := Random(Amount);
color := Pixels[Interval(0, Pred(Width), x + (value - Random(value * 2)), True),
Interval(0, Pred(Height), y + (value - Random(value * 2)), True)];
case BitCount of
32:
1 : begin
for x:=0 to Width-1 do
begin
PDWord(D)^ := color;
Inc(PDWord(D));
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
Pixels[Width-x-1, Height-y-1] := c;
end;
24:
begin
PBGR(D)^ := IntToColor(color);
Inc(PBGR(D));
end;
16:
4 : begin
for x:=0 to Width-1 do
begin
PWord(D)^ := color;
Inc(PWord(D));
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
Pixels[Width-x-1, Height-y-1] := c;
end;
8:
begin
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
8 : begin
P2 := Pointer(Integer(P2)+Width-1);
for x:=0 to Width-1 do
begin
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
1:
begin
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
else
end;
end;
end;
end;
 
procedure TDIB.Sharpen(Amount: Integer);
var
Lin0, Lin1, Lin2: PLines;
pc: PBGR;
cx, x, y: Integer;
Buf: array[0..8] of TBGR;
D: pointer;
c: DWORD;
i: byte;
P1: PByte;
Temp1: TDIB;
 
16: begin
P2 := Pointer(Integer(P2)+(Width-1)*2);
for x:=0 to Width-1 do
begin
D := nil;
GetMem(pc, SizeOf(TBGR));
c := 0;
Temp1 := nil;
case Bitcount of
32, 16, 1: Exit;
24:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
8:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
for i := 0 to 255 do
begin
with Temp1.ColorTable[i] do
begin
Buf[0].B := ColorTable[i - Amount].rgbBlue;
Buf[0].G := ColorTable[i - Amount].rgbGreen;
Buf[0].R := ColorTable[i - Amount].rgbRed;
Buf[1].B := ColorTable[i].rgbBlue;
Buf[1].G := ColorTable[i].rgbGreen;
Buf[1].R := ColorTable[i].rgbRed;
Buf[2].B := ColorTable[i + Amount].rgbBlue;
Buf[2].G := ColorTable[i + Amount].rgbGreen;
Buf[2].R := ColorTable[i + Amount].rgbRed;
Buf[3].B := ColorTable[i - Amount].rgbBlue;
Buf[3].G := ColorTable[i - Amount].rgbGreen;
Buf[3].R := ColorTable[i - Amount].rgbRed;
Buf[4].B := ColorTable[i].rgbBlue;
Buf[4].G := ColorTable[i].rgbGreen;
Buf[4].R := ColorTable[i].rgbRed;
Buf[5].B := ColorTable[i + Amount].rgbBlue;
Buf[5].G := ColorTable[i + Amount].rgbGreen;
Buf[5].R := ColorTable[i + Amount].rgbRed;
Buf[6].B := ColorTable[i - Amount].rgbBlue;
Buf[6].G := ColorTable[i - Amount].rgbGreen;
Buf[6].R := ColorTable[i - Amount].rgbRed;
Buf[7].B := ColorTable[i].rgbBlue;
Buf[7].G := ColorTable[i].rgbGreen;
Buf[7].R := ColorTable[i].rgbRed;
Buf[8].B := ColorTable[i + Amount].rgbBlue;
Buf[8].G := ColorTable[i + Amount].rgbGreen;
Buf[8].R := ColorTable[i + Amount].rgbRed;
Temp1.colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
Temp1.colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
Temp1.colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
 
end;
end;
Temp1.UpdatePalette;
end;
4:
24: begin
P2 := Pointer(Integer(P2)+(Width-1)*3);
for x:=0 to Width-1 do
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
for i := 0 to 255 do
begin
with Temp1.ColorTable[i] do
begin
Buf[0].B := ColorTable[i - Amount].rgbBlue;
Buf[0].G := ColorTable[i - Amount].rgbGreen;
Buf[0].R := ColorTable[i - Amount].rgbRed;
Buf[1].B := ColorTable[i].rgbBlue;
Buf[1].G := ColorTable[i].rgbGreen;
Buf[1].R := ColorTable[i].rgbRed;
Buf[2].B := ColorTable[i + Amount].rgbBlue;
Buf[2].G := ColorTable[i + Amount].rgbGreen;
Buf[2].R := ColorTable[i + Amount].rgbRed;
Buf[3].B := ColorTable[i - Amount].rgbBlue;
Buf[3].G := ColorTable[i - Amount].rgbGreen;
Buf[3].R := ColorTable[i - Amount].rgbRed;
Buf[4].B := ColorTable[i].rgbBlue;
Buf[4].G := ColorTable[i].rgbGreen;
Buf[4].R := ColorTable[i].rgbRed;
Buf[5].B := ColorTable[i + Amount].rgbBlue;
Buf[5].G := ColorTable[i + Amount].rgbGreen;
Buf[5].R := ColorTable[i + Amount].rgbRed;
Buf[6].B := ColorTable[i - Amount].rgbBlue;
Buf[6].G := ColorTable[i - Amount].rgbGreen;
Buf[6].R := ColorTable[i - Amount].rgbRed;
Buf[7].B := ColorTable[i].rgbBlue;
Buf[7].G := ColorTable[i].rgbGreen;
Buf[7].R := ColorTable[i].rgbRed;
Buf[8].B := ColorTable[i + Amount].rgbBlue;
Buf[8].G := ColorTable[i + Amount].rgbGreen;
Buf[8].R := ColorTable[i + Amount].rgbRed;
colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
UpdatePalette;
end;
end;
for y := 0 to Pred(Height) do
32: begin
P2 := Pointer(Integer(P2)+(Width-1)*4);
for x:=0 to Width-1 do
begin
Lin0 := ScanLine[Interval(0, Pred(Height), y - Amount, True)];
Lin1 := ScanLine[y];
Lin2 := ScanLine[Interval(0, Pred(Height), y + Amount, True)];
case Bitcount of
24, 8, 4: D := Temp1.ScanLine[y];
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
24:
begin
cx := Interval(0, Pred(Width), x - Amount, True);
Buf[0] := Lin0[cx];
Buf[1] := Lin1[cx];
Buf[2] := Lin2[cx];
Buf[3] := Lin0[x];
Buf[4] := Lin1[x];
Buf[5] := Lin2[x];
cx := Interval(0, Pred(Width), x + Amount, true);
Buf[6] := Lin0[cx];
Buf[7] := Lin1[cx];
Buf[8] := Lin0[cx];
pc.b := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
pc.g := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
pc.r := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
PBGR(D)^.B := pc.b;
PBGR(D)^.G := pc.g;
PBGR(D)^.R := pc.r;
Inc(PBGR(D));
end;
8:
begin
Inc(PByte(D));
end;
4:
begin
P1 := @PArrayByte(D)[X shr 1];
P1^ := ((P1^ and Mask4n[X and 1]) or ((c shl Shift4[X and 1])));
end;
end;
end;
end;
case BitCount of
24, 8:
begin
Assign(Temp1);
Temp1.Free;
end;
4: Temp1.Free;
end;
FreeMem(pc, SizeOf(TBGR));
end;
 
procedure TDIB.Emboss;
var
x, y: longint;
D, D1, P: pointer;
color: TBGR;
c: DWORD;
P1: PByte;
 
begin
D := nil;
D1 := nil;
P := nil;
case BitCount of
32, 16, 1: Exit;
24:
begin
D := PBits;
D1 := Ptr(Integer(D) + 3);
UpdateProgress(y*2);
end;
else
finally
EndProgress;
end;
for y := 0 to Pred(Height) do
begin
case Bitcount of
8, 4:
begin
P := ScanLine[y];
end;
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
24:
begin
PBGR(D)^.B := ((PBGR(D)^.B + (PBGR(D1)^.B xor $FF)) shr 1);
PBGR(D)^.G := ((PBGR(D)^.G + (PBGR(D1)^.G xor $FF)) shr 1);
PBGR(D)^.R := ((PBGR(D)^.R + (PBGR(D1)^.R xor $FF)) shr 1);
Inc(PBGR(D));
if (y < Height - 2) and (x < Width - 2) then
Inc(PBGR(D1));
end;
8:
begin
color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
c := (color.R + color.G + color.B) shr 1;
PByte(P)^ := c;
Inc(PByte(P));
end;
4:
begin
color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) - 1) shr 1) + 30) div 3;
color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
c := (color.R + color.G + color.B) shr 1;
if c > 64 then
c := c - 8;
P1 := @PArrayByte(P)[X shr 1];
P1^ := (P1^ and Mask4n[X and 1]) or ((c) shl Shift4[X and 1]);
end;
else
end;
end;
case BitCount of
24:
begin
D := Ptr(Integer(D1));
if y < Height - 2 then
D1 := Ptr(Integer(D1) + 6)
else
D1 := Ptr(Integer(ScanLine[Pred(Height)]) + 3);
end;
else
end;
end;
end;
 
procedure TDIB.AddMonoNoise(Amount: Integer);
procedure TDIB.Negative;
var
value: cardinal;
x, y: longint;
a: byte;
D: pointer;
color: DWORD;
P: PByte;
i, i2: Integer;
P: Pointer;
begin
for y := 0 to Pred(Height) do
begin
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24:
begin
value := Random(Amount) - (Amount shr 1);
PBGR(D)^.B := IntToByte(PBGR(D)^.B + value);
PBGR(D)^.G := IntToByte(PBGR(D)^.G + value);
PBGR(D)^.R := IntToByte(PBGR(D)^.R + value);
Inc(PBGR(D));
end;
16: Exit; // I haven't bitmap of this type ! Sorry
8:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 8;
color := Interval(0, 255, (pixels[x, y] - a), True);
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 16;
color := Interval(0, 15, (pixels[x, y] - a), True);
P := @PArrayByte(D)[X shr 1];
P^ := ((P^ and Mask4n[X and 1]) or ((color shl Shift4[X and 1])));
end;
1:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 32;
color := Interval(0, 1, (pixels[x, y] - a), True);
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
else
end;
end;
end;
end;
if Empty then exit;
 
procedure TDIB.AddGradiantNoise(Amount: byte);
var
a, i: byte;
x, y: Integer;
Table: array[0..255] of TBGR;
S, D: pointer;
color: DWORD;
Temp1: TDIB;
P: PByte;
 
if BitCount<=8 then
begin
D := nil;
S := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24:
begin
for i := 0 to 255 do
begin
a := Random(Amount);
Table[i].b := IntToByte(i + a);
Table[i].g := IntToByte(i + a);
Table[i].r := IntToByte(i + a);
end;
end;
16: Exit; // I haven't bitmap of this type ! Sorry
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
a := Random(Amount);
rgbRed := IntToByte(rgbRed + a);
rgbGreen := IntToByte(rgbGreen + a);
rgbBlue := IntToByte(rgbBlue + a);
rgbRed := 255-rgbRed;
rgbGreen := 255-rgbGreen;
rgbBlue := 255-rgbBlue;
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
end else
begin
case BitCount of
24: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ; // I haven't bitmap of this type ! Sorry
24:
begin
PBGR(D)^.B := Table[PBGR(D)^.B].b;
PBGR(D)^.G := Table[PBGR(D)^.G].g;
PBGR(D)^.R := Table[PBGR(D)^.R].r;
Inc(PBGR(D));
end;
16: ; // I haven't bitmap of this type ! Sorry
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
 
function TDIB.FishEye(bmp: TDIB): Boolean;
var
weight, xmid, ymid, fx, fy, r1, r2, dx, dy, rmax: Double;
Amount, ifx, ify, ty, tx, new_red, new_green, new_blue, ix, iy: Integer;
weight_x, weight_y: array[0..1] of Double;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
D: Pointer;
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
Amount := 1;
xmid := Width / 2;
ymid := Height / 2;
rmax := Max(Bmp.Width, Bmp.Height) * Amount;
for ty := 0 to Pred(Height) do
begin
for tx := 0 to Pred(Width) do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(Sqr(dx) + Sqr(dy));
if r1 <> 0 then
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end
else
begin
fx := xmid;
fy := ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := Pred(Width) - (-ifx mod Width)
else
if ifx > Pred(Width) then
ifx := ifx mod Width;
if ify < 0 then
ify := Pred(Height) - (-ify mod Height)
else
if ify > Pred(Height) then
ify := ify mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Height then
sli := ScanLine[ify + iy]
else
sli := ScanLine[Height - ify - iy];
if ifx + ix < Width then
begin
new_red := sli^[ifx + ix].r;
new_green := sli^[ifx + ix].g;
new_blue := sli^[ifx + ix].b;
end
else
begin
new_red := sli^[Width - ifx - ix].r;
new_green := sli^[Width - ifx - ix].g;
new_blue := sli^[Width - ifx - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := Bmp.ScanLine[ty];
slo^[tx].r := Round(total_red);
slo^[tx].g := Round(total_green);
slo^[tx].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
 
function TDIB.SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
var
weight, Theta, cosTheta, sinTheta, sfrom_y, sfrom_x: Double;
ifrom_y, ifrom_x, xDiff, yDiff, to_y, to_x: Integer;
weight_x, weight_y: array[0..1] of Double;
ix, iy, new_red, new_green, new_blue: Integer;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
Theta := -Degree * Pi / 180;
sinTheta := Sin(Theta);
cosTheta := Cos(Theta);
xDiff := (Bmp.Width - Width) div 2;
yDiff := (Bmp.Height - Height) div 2;
for to_y := 0 to Pred(Bmp.Height) do
begin
for to_x := 0 to Pred(Bmp.Width) do
begin
sfrom_x := (cx + (to_x - cx) * cosTheta - (to_y - cy) * sinTheta) - xDiff;
ifrom_x := Trunc(sfrom_x);
sfrom_y := (cy + (to_x - cx) * sinTheta + (to_y - cy) * cosTheta) - yDiff;
ifrom_y := Trunc(sfrom_y);
if sfrom_y >= 0 then
begin
weight_y[1] := sfrom_y - ifrom_y;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(sfrom_y - ifrom_y);
weight_y[1] := 1 - weight_y[0];
end;
if sfrom_x >= 0 then
begin
weight_x[1] := sfrom_x - ifrom_x;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(sfrom_x - ifrom_x);
Weight_x[1] := 1 - weight_x[0];
end;
if ifrom_x < 0 then
ifrom_x := Pred(Width) - (-ifrom_x mod Width)
else
if ifrom_x > Pred(Width) then
ifrom_x := ifrom_x mod Width;
if ifrom_y < 0 then
ifrom_y := Pred(Height) - (-ifrom_y mod Height)
else
if ifrom_y > Pred(Height) then
ifrom_y := ifrom_y mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ifrom_y + iy < Height then
sli := ScanLine[ifrom_y + iy]
else
sli := ScanLine[Height - ifrom_y - iy];
if ifrom_x + ix < Width then
begin
new_red := sli^[ifrom_x + ix].r;
new_green := sli^[ifrom_x + ix].g;
new_blue := sli^[ifrom_x + ix].b;
end
else
begin
new_red := sli^[Width - ifrom_x - ix].r;
new_green := sli^[Width - ifrom_x - ix].g;
new_blue := sli^[Width - ifrom_x - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := Bmp.ScanLine[to_y];
slo^[to_x].r := Round(total_red);
slo^[to_x].g := Round(total_green);
slo^[to_x].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
 
function TDIB.Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
var
x, y, dx, dy, sdx, sdy, xDiff, yDiff, isinTheta, icosTheta: Integer;
D, S: Pointer;
sinTheta, cosTheta, Theta: Double;
Col: TBGR;
i: byte;
color: DWORD;
P: PByte;
begin
D := nil;
S := nil;
Result := True;
dst.SetSize(Width, Height, Bitcount);
dst.Canvas.Brush.Color := clBlack;
Dst.Canvas.FillRect(Bounds(0, 0, Width, Height));
case BitCount of
32, 16:
begin
Result := False;
Exit;
end;
8, 4, 1:
begin
for i := 0 to 255 do
Dst.ColorTable[i] := ColorTable[i];
Dst.UpdatePalette;
end;
end;
Theta := -Angle * Pi / 180;
sinTheta := Sin(Theta);
cosTheta := Cos(Theta);
xDiff := (Dst.Width - Width) div 2;
yDiff := (Dst.Height - Height) div 2;
isinTheta := Round(sinTheta * $10000);
icosTheta := Round(cosTheta * $10000);
for y := 0 to Pred(Dst.Height) do
begin
case BitCount of
4, 1:
begin
D := Dst.ScanLine[y];
S := ScanLine[y];
end;
else
end;
sdx := Round(((cx + (-cx) * cosTheta - (y - cy) * sinTheta) - xDiff) * $10000);
sdy := Round(((cy + (-cy) * sinTheta + (y - cy) * cosTheta) - yDiff) * $10000);
for x := 0 to Pred(Dst.Width) do
begin
dx := (sdx shr 16);
dy := (sdy shr 16);
if (dx > -1) and (dx < Width) and (dy > -1) and (dy < Height) then
begin
case bitcount of
8, 24: Dst.pixels[x, y] := Pixels[dx, dy];
4:
begin
pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
color := col.r + col.g + col.b;
Inc(PByte(S));
P := @PArrayByte(D)[x shr 1];
P^ := (P^ and Mask4n[x and 1]) or (color shl Shift4[x and 1]);
end;
1:
begin
pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
color := col.r + col.g + col.b;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
end;
end;
Inc(sdx, icosTheta);
Inc(sdy, isinTheta);
end;
end;
end;
mov ecx,edx
shr ecx,2
add eax,ecx*4
 
procedure TDIB.GaussianBlur(Bmp: TDIB; Amount: Integer);
var
i: Integer;
begin
for i := 1 to Amount do
Bmp.SplitBlur(i);
end;
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@byte_skip
 
procedure TDIB.SplitBlur(Amount: Integer);
var
Lin1, Lin2: PLines;
cx, x, y: Integer;
Buf: array[0..3] of TBGR;
D: Pointer;
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
 
begin
case Bitcount of
32, 16, 8, 4, 1: Exit;
@@byte_skip:
end;
for y := 0 to Pred(Height) do
begin
Lin1 := ScanLine[TrimInt(y + Amount, 0, Pred(Height))];
Lin2 := ScanLine[TrimInt(y - Amount, 0, Pred(Height))];
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
cx := TrimInt(x + Amount, 0, Pred(Width));
Buf[0] := Lin1[cx];
Buf[1] := Lin2[cx];
cx := TrimInt(x - Amount, 0, Pred(Width));
Buf[2] := Lin1[cx];
Buf[3] := Lin2[cx];
PBGR(D)^.b := (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b) shr 2;
PBGR(D)^.g := (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g) shr 2;
PBGR(D)^.r := (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r) shr 2;
Inc(PBGR(D));
end;
end;
end;
 
function TDIB.Twist(bmp: TDIB; Amount: byte): Boolean;
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
OFFSET: Single;
ty, tx, ix, iy: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green, new_blue: Integer;
total_red, total_green, total_blue: Single;
sli, slo: PLines;
 
function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
 
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
if Amount = 0 then
Amount := 1;
OFFSET := -(Pi / 2);
dx := Pred(Width);
dy := Pred(Height);
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Pred(Width)) / 2;
tymid := (Pred(Height)) / 2;
fxmid := (Pred(Width)) / 2;
fymid := (Pred(Height)) / 2;
if tx2 >= Width then
tx2 := Pred(Width);
if ty2 >= Height then
ty2 := Pred(Height);
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
ify := Trunc(fy);
ifx := Trunc(fx);
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := Pred(Width) - (-ifx mod Width)
else
if ifx > Pred(Width) then
ifx := ifx mod Width;
if ify < 0 then
ify := Pred(Height) - (-ify mod Height)
else
if ify > Pred(Height) then
ify := ify mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Height then
sli := ScanLine[ify + iy]
else
sli := ScanLine[Height - ify - iy];
if ifx + ix < Width then
begin
new_red := sli^[ifx + ix].r;
new_green := sli^[ifx + ix].g;
new_blue := sli^[ifx + ix].b;
end
else
begin
new_red := sli^[Width - ifx - ix].r;
new_green := sli^[Width - ifx - ix].g;
new_blue := sli^[Width - ifx - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := bmp.ScanLine[ty];
slo^[tx].r := Round(total_red);
slo^[tx].g := Round(total_green);
slo^[tx].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
function TDIB.TrimInt(i, Min, Max: Integer): Integer;
begin
if i > Max then
Result := Max
else
if i < Min then
Result := Min
else
Result := i;
end;
 
function TDIB.IntToByte(i: Integer): Byte;
begin
if i > 255 then
Result := 255
else
if i < 0 then
Result := 0
else
Result := i;
end;
 
//--------------------------------------------------------------------------------------------------
// End of these New Special Effect //
// Please contributes to add effects and filters to this collection //
// Please, work to implement 32,16,8,4,2 BitCount's DIB //
// Have fun - Mickey - Good job //
//--------------------------------------------------------------------------------------------------
 
function TDIB.GetAlphaChannel: TDIB;
begin
RetAlphaChannel(Result);
 
FFreeList.Add(Result);
end;
 
procedure TDIB.SetAlphaChannel(const Value: TDIB);
begin
if not AssignAlphaChannel(Value{$IFNDEF VER4UP}, False{$ENDIF}) then
Exception.Create('Cannot set alphachannel from DIB.');
end;
 
procedure TDIB.Fill(aColor: TColor);
begin
Canvas.Brush.Color := aColor;
Canvas.FillRect(ClientRect);
end;
 
function TDIB.GetClientRect: TRect;
begin
Result := Bounds(0, 0, Width, Height);
end;
 
{ TCustomDXDIB }
 
constructor TCustomDXDIB.Create(AOnwer: TComponent);
5357,20 → 3078,17
begin
inherited Canvas.StretchDraw(Bounds(-(Width - ClientWidth) div 2,
-(Height - ClientHeight) div 2, Width, Height), FDIB);
end
else
end else
begin
inherited Canvas.StretchDraw(Bounds(0, 0, Width, Height), FDIB);
end;
end
else
end else
begin
if FCenter then
begin
inherited Canvas.Draw(-(Width - ClientWidth) div 2, -(Height - ClientHeight) div 2,
FDIB);
end
else
end else
begin
inherited Canvas.Draw(0, 0, FDIB);
end;
5410,14 → 3128,11
if r > r2 then
r := r2;
Draw2(Round(r * ClientWidth), Round(r * ClientHeight));
end
else
end else
Draw2(ViewWidth2, ViewHeight2);
end
else
end else
Draw2(ViewWidth2, ViewHeight2);
end
else
end else
begin
if FAutoStretch then
begin
5428,11 → 3143,9
if r > r2 then
r := r2;
Draw2(Round(r * FDIB.Width), Round(r * FDIB.Height));
end
else
end else
Draw2(FDIB.Width, FDIB.Height);
end
else
end else
if FStretch then
begin
if FKeepAspect then
5442,11 → 3155,9
if r > r2 then
r := r2;
Draw2(Round(r * FDIB.Width), Round(r * FDIB.Height));
end
else
end else
Draw2(ClientWidth, ClientHeight);
end
else
end else
Draw2(FDIB.Width, FDIB.Height);
end;
end;
5517,4382 → 3228,6
end;
end;
 
{ DXFusion -> }
 
function PosValue(Value: Integer): Integer;
begin
if Value < 0 then result := 0 else result := Value;
end;
 
procedure TDIB.CreateDIBFromBitmap(const Bitmap: TBitmap);
var
pf: Integer;
begin
if Bitmap.PixelFormat = pf32bit then pf := 32 else pf := 24;
SetSize(Bitmap.Width, Bitmap.Height, pf); {always >=24}
Canvas.Draw(0, 0, Bitmap);
end;
 
function TDIB.CreateBitmapFromDIB: TBitmap;
//var
// X, Y: Integer;
begin
Result := TBitmap.Create;
if BitCount = 32 then
Result.PixelFormat := pf32bit
else if BitCount = 24 then
Result.PixelFormat := pf24bit
else if BitCount = 16 then
Result.PixelFormat := pf16bit
else if BitCount = 8 then
Result.PixelFormat := pf8bit
else Result.PixelFormat := pf24bit;
Result.Width := Width;
Result.Height := Height;
Result.Canvas.Draw(0, 0, Self);
// for Y := 0 to Height - 1 do
// for X := 0 to Width - 1 do
// Result.Canvas.Pixels[X, Y] := Canvas.Pixels[X, Y];
end;
 
procedure TDIB.DrawTo(SrcDIB: TDIB; X, Y, Width, Height,
SourceX, SourceY: Integer);
begin
SrcDIB.DrawOn(Rect(X, Y, Width, Height), Self.Canvas, SourceX, SourceY);
end;
 
procedure TDIB.DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
 
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawShadow(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer; FilterMode: TFilterMode);
var
i, j: Integer;
p1, p2: PByte;
FW: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
FW := Frame * Width;
for i := 1 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
Inc(p1, 3 * (X + 1));
Inc(p2, 3 * (FW + 1));
for j := 1 to Width - 1 do
begin
if (p2^ = 0) then
begin
case FilterMode of
fmNormal, fmMix50:
begin
p1^ := p1^ shr 1; // Blue
Inc(p1);
p1^ := p1^ shr 1; // Green
Inc(p1);
p1^ := p1^ shr 1; // Red
Inc(p1);
end;
fmMix25:
begin
p1^ := p1^ - p1^ shr 2; // Blue
Inc(p1);
p1^ := p1^ - p1^ shr 2; // Green
Inc(p1);
p1^ := p1^ - p1^ shr 2; // Red
Inc(p1);
end;
fmMix75:
begin
p1^ := p1^ shr 2; // Blue
Inc(p1);
p1^ := p1^ shr 2; // Green
Inc(p1);
p1^ := p1^ shr 2; // Red
Inc(p1);
end;
end;
end
else
Inc(p1, 3); // Not in the loop...
Inc(p2, 3);
end;
end;
end;
 
procedure TDIB.DrawShadows(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer; Alpha: Byte);
{plynule nastavovani stiny dle alpha}
type
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of TBGR;
var
i, j, l1, l2: Integer;
p1, p2: P3ByteArray;
FW: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
FW := Frame * Width;
for i := 0 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
l1 := X;
l2 := FW;
for j := 0 to Width - 1 do
begin
if (p2[j + l2].B = 0) and (p2[j + l2].G = 0) and (p2[j + l2].R = 0) then
begin
p1[J + l1].B := Round(p1[J + l1].B / $FF * Alpha);
p1[J + l1].G := Round(p1[J + l1].G / $FF * Alpha);
p1[J + l1].R := Round(p1[J + l1].R / $FF * Alpha);
end
end;
end;
end;
 
procedure TDIB.DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer);
var
frameoffset, i, j: Integer;
p1, p2: pByte;
XOffset: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
frameoffset := 3 * (Frame * Width) + 3;
XOffset := 3 * X + 3;
for i := 1 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
inc(p1, XOffset);
inc(p2, frameoffset);
for j := 1 to Width - 1 do
begin
p1^ := (p2^ * p1^) shr 8; // R
inc(p1);
inc(p2);
p1^ := (p2^ * p1^) shr 8; // G
inc(p1);
inc(p2);
p1^ := (p2^ * p1^) shr 8; // B
inc(p1);
inc(p2);
end;
end;
end;
 
procedure TDIB.DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor; FilterMode: TFilterMode);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
BitSwitch1, BitSwitch2: Boolean;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if Odd(Y) then BitSwitch1 := true else BitSwitch1 := false;
if Odd(X) then BitSwitch2 := true else BitSwitch2 := false;
 
for j := StartY to EndY - 1 do
begin
BitSwitch1 := not BitSwitch1;
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
BitSwitch2 := not BitSwitch2;
 
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
case FilterMode of
fmNormal, fmMix50: if not (n = Color) and (BitSwitch1 xor BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
fmMix25: if not (n = Color) and (BitSwitch1 and BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
fmMix75: if not (n = Color) and (BitSwitch1 or BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height, Alpha, Frame:
Integer);
var
frameoffset, i, j, Wid: Integer;
p1, p2: pByte;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
if (Alpha < 1) or (Alpha > 256) then Exit;
Wid := Width shl 1 + Width;
frameoffset := Wid * Frame;
for i := 1 to Height - 1 do
begin
if (i + Y) > (Self.Height - 1) then Break; //add 25.5.2004 JB.
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
inc(p1, X shl 1 + X + 3);
inc(p2, frameoffset + 3);
for j := 3 to Wid - 4 do
begin
inc(p1^, (Alpha - p1^) * p2^ shr 8);
inc(p1);
inc(p2);
end;
end;
end;
 
procedure TDIB.DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := (p1[k2] + p2[k1]) shr 1;
p1[k2 + 1] := (p1[k2 + 1] + p2[k1 + 1]) shr 1;
p1[k2 + 2] := (p1[k2 + 2] + p2[k1 + 2]) shr 1;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY, Alpha: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := (p1[k2] * (256 - Alpha) + p2[k1] * Alpha) shr 8;
p1[k2 + 1] := (p1[k2 + 1] * (256 - Alpha) + p2[k1 + 1] * Alpha) shr 8;
p1[k2 + 2] := (p1[k2 + 2] * (256 - Alpha) + p2[k1 + 2] * Alpha) shr 8;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y,
Width, Height, SourceX, SourceY: Integer);
var
i, j: Integer;
k1, k2, k3: Integer;
p1, p2, p3: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
p3 := MaskDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
k3 := 0;
 
for i := SourceX to SourceX + Width - 1 do
begin
p1[k2] := (p1[k2] * (256 - p3[k3]) + p2[k1] * p3[k3]) shr 8;
p1[k2 + 1] := (p1[k2 + 1] * (256 - p3[k3]) + p2[k1 + 1] * p3[k3]) shr 8;
p1[k2 + 2] := (p1[k2 + 2] * (256 - p3[k3]) + p2[k1 + 2] * p3[k3]) shr 8;
 
k1 := k1 + 3;
k2 := k2 + 3;
k3 := k3 + 3;
end;
end;
end;
 
procedure TDIB.DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j, r, g, b: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
r := 0;
g := 0;
b := 0;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if Random(100) < 50 then
begin
b := p1[k2];
g := p1[k2 + 1];
r := p1[k2 + 2];
end;
 
if not (n = Color) then
begin
p1[k2] := b;
p1[k2 + 1] := g;
p1[k2 + 2] := r;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawMono(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
var
i, j, r1, g1, b1, r2, g2, b2: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
Startk1, Startk2, StartY, EndY, DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
r1 := GetRValue(BackColor);
g1 := GetGValue(BackColor);
b1 := GetBValue(BackColor);
 
r2 := GetRValue(ForeColor);
g2 := GetGValue(ForeColor);
b2 := GetBValue(ForeColor);
 
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if (n = TransColor) then
begin
p1[k2] := b1;
p1[k2 + 1] := g1;
p1[k2 + 2] := r1;
end
else
begin
p1[k2] := b2;
p1[k2 + 1] := g2;
p1[k2 + 2] := r2;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
var i, j, k: Integer;
p1, p2, p3, p4: PByteArray;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
for i := 1 to SrcDIB.Height - 2 do
begin
p1 := SrcDIB.ScanLine[i - 1];
p2 := SrcDIB.ScanLine[i];
p3 := SrcDIB.ScanLine[i + 1];
p4 := Self.ScanLine[i];
for j := 3 to 3 * SrcDIB.Width - 4 do
begin
k := (p1[j - 3] * Setting[0] + p1[j] * Setting[1] + p1[j + 3] * Setting[2] +
p2[j - 3] * Setting[3] + p2[j] * Setting[4] + p2[j + 3] * Setting[5] +
p3[j - 3] * Setting[6] + p3[j] * Setting[7] + p3[j + 3] * Setting[8])
div Setting[9];
if k < 0 then k := 0;
if k > 255 then k := 255;
p4[j] := k;
end;
end;
end;
 
procedure TDIB.DrawAntialias(SrcDIB: TDIB);
var i, j, k, l, m: Integer;
p1, p2, p3: PByteArray;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
for i := 1 to Self.Height - 1 do
begin
k := i shl 1;
p1 := SrcDIB.Scanline[k];
p2 := SrcDIB.Scanline[k + 1];
p3 := Self.Scanline[i];
for j := 1 to Self.Width - 1 do
begin
m := 3 * j;
l := m shl 1;
p3[m] := (p1[l] + p1[l + 3] + p2[l] + p2[l + 3]) shr 2;
p3[m + 1] := (p1[l + 1] + p1[l + 4] + p2[l + 1] + p2[l + 4]) shr 2;
p3[m + 2] := (p1[l + 2] + p1[l + 5] + p2[l + 2] + p2[l + 5]) shr 2;
end;
end;
end;
 
procedure TDIB.FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
FilterMode: TFilterMode);
var
i, j: Integer;
t: TColor;
r1, g1, b1, r2, g2, b2: Integer;
begin
j := ROUND(Sqrt(Sqr(ABS(X2 - X1)) + Sqr(ABS(Y2 - Y1))));
if j < 1 then Exit;
 
r1 := GetRValue(Color);
g1 := GetGValue(Color);
b1 := GetBValue(Color);
 
for i := 0 to j do
begin
t := Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)];
r2 := GetRValue(t);
g2 := GetGValue(t);
b2 := GetBValue(t);
case FilterMode of
fmNormal: t := RGB(r1 + (((256 - r1) * r2) shr 8),
g1 + (((256 - g1) * g2) shr 8),
b1 + (((256 - b1) * b2) shr 8));
fmMix25: t := RGB((r1 + r2 * 3) shr 2, (g1 + g2 * 3) shr 2, (b1 + b2 * 3) shr 2);
fmMix50: t := RGB((r1 + r2) shr 1, (g1 + g2) shr 1, (b1 + b2) shr 1);
fmMix75: t := RGB((r1 * 3 + r2) shr 2, (g1 * 3 + g2) shr 2, (b1 * 3 + b2) shr 2);
end;
Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)] := t;
end;
end;
 
procedure TDIB.FilterRect(X, Y, Width, Height: Integer;
Color: TColor; FilterMode: TFilterMode);
var
i, j, r, g, b, C1: Integer;
p1, p2, p3: pByte;
begin
if Self.BitCount <> 24 then Exit;
 
r := GetRValue(Color);
g := GetGValue(Color);
b := GetBValue(Color);
 
for i := 0 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
Inc(p1, (3 * X));
for j := 0 to Width - 1 do
begin
case FilterMode of
fmNormal:
begin
p2 := p1;
Inc(p2);
p3 := p2;
Inc(p3);
C1 := (p1^ + p2^ + p3^) div 3;
 
p1^ := (C1 * b) shr 8;
Inc(p1);
p1^ := (C1 * g) shr 8;
Inc(p1);
p1^ := (C1 * r) shr 8;
Inc(p1);
end;
fmMix25:
begin
p1^ := (3 * p1^ + b) shr 2;
Inc(p1);
p1^ := (3 * p1^ + g) shr 2;
Inc(p1);
p1^ := (3 * p1^ + r) shr 2;
Inc(p1);
end;
fmMix50:
begin
p1^ := (p1^ + b) shr 1;
Inc(p1);
p1^ := (p1^ + g) shr 1;
Inc(p1);
p1^ := (p1^ + r) shr 1;
Inc(p1);
end;
fmMix75:
begin
p1^ := (p1^ + 3 * b) shr 2;
Inc(p1);
p1^ := (p1^ + 3 * g) shr 2;
Inc(p1);
p1^ := (p1^ + 3 * r) shr 2;
Inc(p1);
end;
end;
end;
end;
end;
 
procedure TDIB.InitLight(Count, Detail: Integer);
var
i, j: Integer;
begin
LG_COUNT := Count;
LG_DETAIL := Detail;
 
for i := 0 to 255 do // Build Lightning LUT
for j := 0 to 255 do
FLUTDist[i, j] := ROUND(Sqrt(Sqr(i * 10) + Sqr(j * 10)));
end;
 
procedure TDIB.DrawLights(FLight: TLightArray;
AmbientLight: TColor);
var
i, j, l, m, n, o, q, D1, D2, R, G, B, AR, AG, AB: Integer;
P: array{$IFNDEF VER4UP} [0..4096]{$ENDIF} of PByteArray;
begin
if Self.BitCount <> 24 then Exit;
 
{$IFDEF VER4UP}
SetLength(P, LG_DETAIL);
{$ENDIF}
AR := GetRValue(AmbientLight);
AG := GetGValue(AmbientLight);
AB := GetBValue(AmbientLight);
 
for i := (Self.Height div (LG_DETAIL + 1)) downto 1 do
begin
for o := 0 to LG_DETAIL do
P[o] := Self.Scanline[(LG_DETAIL + 1) * i - o];
 
for j := (Self.Width div (LG_DETAIL + 1)) downto 1 do
begin
R := AR;
G := AG;
B := AB;
 
for l := LG_COUNT - 1 downto 0 do // Check the lightsources
begin
D1 := ABS(j * (LG_DETAIL + 1) - FLight[l].X) div FLight[l].Size1;
D2 := ABS(i * (LG_DETAIL + 1) - FLight[l].Y) div FLight[l].Size2;
if D1 > 255 then D1 := 255;
if D2 > 255 then D2 := 255;
 
m := 255 - FLUTDist[D1, D2];
if m < 0 then m := 0;
 
Inc(R, (PosValue(GetRValue(FLight[l].Color) - R) * m shr 8));
Inc(G, (PosValue(GetGValue(FLight[l].Color) - G) * m shr 8));
Inc(B, (PosValue(GetBValue(FLight[l].Color) - B) * m shr 8));
end;
 
for q := LG_DETAIL downto 0 do
begin
n := 3 * (j * (LG_DETAIL + 1) - q);
 
for o := LG_DETAIL downto 0 do
begin
P[o][n] := (P[o][n] * B) shr 8;
P[o][n + 1] := (P[o][n + 1] * G) shr 8;
P[o][n + 2] := (P[o][n + 2] * R) shr 8;
end;
end;
end;
end;
{$IFDEF VER4UP}
SetLength(P, 0);
{$ENDIF}
end;
 
procedure TDIB.DrawOn(Dest: TRect; DestCanvas: TCanvas; Xsrc, Ysrc: Integer);
{procedure is supplement of original TDIBUltra function}
begin
//if not AsSigned(SrcCanvas) then Exit;
if (Xsrc < 0) then
begin
Dec(Dest.Left, Xsrc);
Inc(Dest.Right {Width }, Xsrc);
Xsrc := 0
end;
if (Ysrc < 0) then
begin
Dec(Dest.Top, Ysrc);
Inc(Dest.Bottom {Height}, Ysrc);
Ysrc := 0
end;
BitBlt(DestCanvas.Handle, Dest.Left, Dest.Top, Dest.Right, Dest.Bottom, Self.Canvas.Handle, Xsrc, Ysrc, SRCCOPY);
end;
 
{ DXFusion <- }
 
{ added effect for DIB }
 
function IntToByte(i: Integer): Byte;
begin
if i > 255 then Result := 255
else if i < 0 then Result := 0
else Result := i;
end;
 
{standalone routine}
 
procedure TDIB.Darker(Percent: Integer);
{color to dark in percent}
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := Round(R * Percent / 100);
p0[x * 3 + 1] := Round(G * Percent / 100);
p0[x * 3 + 2] := Round(B * Percent / 100);
end;
end;
end;
 
procedure TDIB.Lighter(Percent: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := Round(R * Percent / 100) + Round(255 - Percent / 100 * 255);
p0[x * 3 + 1] := Round(G * Percent / 100) + Round(255 - Percent / 100 * 255);
p0[x * 3 + 2] := Round(B * Percent / 100) + Round(255 - Percent / 100 * 255);
end;
end;
end;
 
procedure TDIB.Darkness(Amount: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r - ((r) * Amount) div 255);
p0[x * 3 + 1] := IntToByte(g - ((g) * Amount) div 255);
p0[x * 3 + 2] := IntToByte(b - ((b) * Amount) div 255);
end;
end;
end;
 
function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i > Max then Result := Max
else if i < Min then Result := Min
else Result := i;
end;
 
procedure TDIB.DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
var
Top, Bottom, Left, Right, eww, nsw, fx, fy, wx, wy: Extended;
cAngle, sAngle: Double;
xDiff, yDiff, ifx, ify, px, py, ix, iy, x, y: Integer;
nw, ne, sw, se: TBGR;
P1, P2, P3: Pbytearray;
begin
Angle := angle;
Angle := -Angle * Pi / 180;
sAngle := Sin(Angle);
cAngle := Cos(Angle);
xDiff := (Self.Width - Src.Width) div 2;
yDiff := (Self.Height - Src.Height) div 2;
for y := 0 to Self.Height - 1 do
begin
P3 := Self.scanline[y];
py := 2 * (y - cy) + 1;
for x := 0 to Self.Width - 1 do
begin
px := 2 * (x - cx) + 1;
fx := (((px * cAngle - py * sAngle) - 1) / 2 + cx) - xDiff;
fy := (((px * sAngle + py * cAngle) - 1) / 2 + cy) - yDiff;
ifx := Round(fx);
ify := Round(fy);
 
if (ifx > -1) and (ifx < Src.Width) and (ify > -1) and (ify < Src.Height) then
begin
eww := fx - ifx;
nsw := fy - ify;
iy := TrimInt(ify + 1, 0, Src.Height - 1);
ix := TrimInt(ifx + 1, 0, Src.Width - 1);
P1 := Src.scanline[ify];
P2 := Src.scanline[iy];
nw.r := P1[ifx * 3];
nw.g := P1[ifx * 3 + 1];
nw.b := P1[ifx * 3 + 2];
ne.r := P1[ix * 3];
ne.g := P1[ix * 3 + 1];
ne.b := P1[ix * 3 + 2];
sw.r := P2[ifx * 3];
sw.g := P2[ifx * 3 + 1];
sw.b := P2[ifx * 3 + 2];
se.r := P2[ix * 3];
se.g := P2[ix * 3 + 1];
se.b := P2[ix * 3 + 2];
 
Top := nw.b + eww * (ne.b - nw.b);
Bottom := sw.b + eww * (se.b - sw.b);
P3[x * 3 + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));
 
Top := nw.g + eww * (ne.g - nw.g);
Bottom := sw.g + eww * (se.g - sw.g);
P3[x * 3 + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));
 
Top := nw.r + eww * (ne.r - nw.r);
Bottom := sw.r + eww * (se.r - sw.r);
P3[x * 3] := IntToByte(Round(Top + nsw * (Bottom - Top)));
end;
end;
end;
end;
 
//----------------------
//--- 24 bit count routines ----------------------
//----------------------
 
procedure TDIB.DoInvert;
procedure PicInvert(src: TDIB);
var w, h, x, y: Integer;
p: pbytearray;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
for y := 0 to h - 1 do
begin
p := src.scanline[y];
for x := 0 to w - 1 do
begin
p[x * 3] := not p[x * 3];
p[x * 3 + 1] := not p[x * 3 + 1];
p[x * 3 + 2] := not p[x * 3 + 2];
end;
end;
end;
begin
PicInvert(Self);
end;
 
procedure TDIB.DoAddColorNoise(Amount: Integer);
procedure AddColorNoise(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
x, y, r, g, b: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.ScanLine[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3] + (Random(Amount) - (Amount shr 1));
g := p0[x * 3 + 1] + (Random(Amount) - (Amount shr 1));
b := p0[x * 3 + 2] + (Random(Amount) - (Amount shr 1));
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
AddColorNoise(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoAddMonoNoise(Amount: Integer);
procedure _AddMonoNoise(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
x, y, a, r, g, b: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
a := Random(Amount) - (Amount shr 1);
r := p0[x * 3] + a;
g := p0[x * 3 + 1] + a;
b := p0[x * 3 + 2] + a;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_AddMonoNoise(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoAntiAlias;
procedure AntiAlias(clip: TDIB);
procedure AntiAliasRect(clip: TDIB; XOrigin, YOrigin, XFinal, YFinal: Integer);
var Memo, x, y: Integer; (* Composantes primaires des points environnants *)
p0, p1, p2: pbytearray;
begin
if XFinal < XOrigin then begin Memo := XOrigin; XOrigin := XFinal; XFinal := Memo; end; (* Inversion des valeurs *)
if YFinal < YOrigin then begin Memo := YOrigin; YOrigin := YFinal; YFinal := Memo; end; (* si diff‚rence n‚gative*)
XOrigin := max(1, XOrigin);
YOrigin := max(1, YOrigin);
XFinal := min(clip.width - 2, XFinal);
YFinal := min(clip.height - 2, YFinal);
clip.BitCount := 24;
for y := YOrigin to YFinal do
begin
p0 := clip.ScanLine[y - 1];
p1 := clip.scanline[y];
p2 := clip.ScanLine[y + 1];
for x := XOrigin to XFinal do
begin
p1[x * 3] := (p0[x * 3] + p2[x * 3] + p1[(x - 1) * 3] + p1[(x + 1) * 3]) div 4;
p1[x * 3 + 1] := (p0[x * 3 + 1] + p2[x * 3 + 1] + p1[(x - 1) * 3 + 1] + p1[(x + 1) * 3 + 1]) div 4;
p1[x * 3 + 2] := (p0[x * 3 + 2] + p2[x * 3 + 2] + p1[(x - 1) * 3 + 2] + p1[(x + 1) * 3 + 2]) div 4;
end;
end;
end;
begin
AntiAliasRect(clip, 0, 0, clip.width, clip.height);
end;
begin
AntiAlias(Self);
end;
 
procedure TDIB.DoContrast(Amount: Integer);
procedure _Contrast(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
rg, gg, bg, r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rg := (Abs(127 - r) * Amount) div 255;
gg := (Abs(127 - g) * Amount) div 255;
bg := (Abs(127 - b) * Amount) div 255;
if r > 127 then r := r + rg else r := r - rg;
if g > 127 then g := g + gg else g := g - gg;
if b > 127 then b := b + bg else b := b - bg;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Contrast(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoFishEye(Amount: Integer);
procedure _FishEye(var Bmp, Dst: TDIB; Amount: Extended);
var
xmid, ymid: Single;
fx, fy: Single;
r1, r2: Single;
ifx, ify: Integer;
dx, dy: Single;
rmax: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PByteArray;
begin
xmid := Bmp.Width / 2;
ymid := Bmp.Height / 2;
rmax := Dst.Width * Amount;
 
for ty := 0 to Dst.Height - 1 do
begin
for tx := 0 to Dst.Width - 1 do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(dx * dx + dy * dy);
if r1 = 0 then
begin
fx := xmid;
fy := ymid;
end
else
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
 
if ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
else if ifx > Bmp.Width - 1 then
ifx := ifx mod Bmp.Width;
if ify < 0 then
ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
else if ify > Bmp.Height - 1 then
ify := ify mod Bmp.Height;
 
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
if ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
 
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
_FishEye(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoGrayScale;
procedure GrayScale(var clip: TDIB);
var
p0: pbytearray;
Gray, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
Gray := Round(p0[x * 3] * 0.3 + p0[x * 3 + 1] * 0.59 + p0[x * 3 + 2] * 0.11);
p0[x * 3] := Gray;
p0[x * 3 + 1] := Gray;
p0[x * 3 + 2] := Gray;
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
GrayScale(BB);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoLightness(Amount: Integer);
procedure _Lightness(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r + ((255 - r) * Amount) div 255);
p0[x * 3 + 1] := IntToByte(g + ((255 - g) * Amount) div 255);
p0[x * 3 + 2] := IntToByte(b + ((255 - b) * Amount) div 255);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Lightness(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoDarkness(Amount: Integer);
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
BB.Darkness(Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoSaturation(Amount: Integer);
procedure _Saturation(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
Gray, r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
Gray := (r + g + b) div 3;
p0[x * 3] := IntToByte(Gray + (((r - Gray) * Amount) div 255));
p0[x * 3 + 1] := IntToByte(Gray + (((g - Gray) * Amount) div 255));
p0[x * 3 + 2] := IntToByte(Gray + (((b - Gray) * Amount) div 255));
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Saturation(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoSplitBlur(Amount: Integer);
{NOTE: For a gaussian blur is amount 3}
procedure _SplitBlur(var clip: TDIB; Amount: Integer);
var
p0, p1, p2: pbytearray;
cx, x, y: Integer;
Buf: array[0..3, 0..2] of byte;
begin
if Amount = 0 then Exit;
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
if y - Amount < 0 then p1 := clip.scanline[y]
else {y-Amount>0} p1 := clip.ScanLine[y - Amount];
if y + Amount < clip.Height then p2 := clip.ScanLine[y + Amount]
else {y+Amount>=Height} p2 := clip.ScanLine[clip.Height - y];
 
for x := 0 to clip.Width - 1 do
begin
if x - Amount < 0 then cx := x
else {x-Amount>0} cx := x - Amount;
Buf[0, 0] := p1[cx * 3];
Buf[0, 1] := p1[cx * 3 + 1];
Buf[0, 2] := p1[cx * 3 + 2];
Buf[1, 0] := p2[cx * 3];
Buf[1, 1] := p2[cx * 3 + 1];
Buf[1, 2] := p2[cx * 3 + 2];
if x + Amount < clip.Width then cx := x + Amount
else {x+Amount>=Width} cx := clip.Width - x;
Buf[2, 0] := p1[cx * 3];
Buf[2, 1] := p1[cx * 3 + 1];
Buf[2, 2] := p1[cx * 3 + 2];
Buf[3, 0] := p2[cx * 3];
Buf[3, 1] := p2[cx * 3 + 1];
Buf[3, 2] := p2[cx * 3 + 2];
p0[x * 3] := (Buf[0, 0] + Buf[1, 0] + Buf[2, 0] + Buf[3, 0]) shr 2;
p0[x * 3 + 1] := (Buf[0, 1] + Buf[1, 1] + Buf[2, 1] + Buf[3, 1]) shr 2;
p0[x * 3 + 2] := (Buf[0, 2] + Buf[1, 2] + Buf[2, 2] + Buf[3, 2]) shr 2;
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_SplitBlur(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoGaussianBlur(Amount: Integer);
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.BitCount := 24;
BB.Assign(Self);
GaussianBlur(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoMosaic(Size: Integer);
procedure Mosaic(var Bm: TDIB; size: Integer);
var
x, y, i, j: Integer;
p1, p2: pbytearray;
r, g, b: byte;
begin
y := 0;
repeat
p1 := bm.scanline[y];
repeat
j := 1;
repeat
p2 := bm.scanline[y];
x := 0;
repeat
r := p1[x * 3];
g := p1[x * 3 + 1];
b := p1[x * 3 + 2];
i := 1;
repeat
p2[x * 3] := r;
p2[x * 3 + 1] := g;
p2[x * 3 + 2] := b;
inc(x);
inc(i);
until (x >= bm.width) or (i > size);
until x >= bm.width;
inc(j);
inc(y);
until (y >= bm.height) or (j > size);
until (y >= bm.height) or (x >= bm.width);
until y >= bm.height;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
Mosaic(BB, Size);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoTwist(Amount: Integer);
procedure _Twist(var Bmp, Dst: TDIB; Amount: Integer);
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
OFFSET: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PBytearray;
 
function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
 
begin
OFFSET := -(Pi / 2);
dx := Bmp.Width - 1;
dy := Bmp.Height - 1;
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Bmp.Width - 1) / 2; //Adjust these to move center of rotation
tymid := (Bmp.Height - 1) / 2; //Adjust these to move ......
fxmid := (Bmp.Width - 1) / 2;
fymid := (Bmp.Height - 1) / 2;
if tx2 >= Bmp.Width then tx2 := Bmp.Width - 1;
if ty2 >= Bmp.Height then ty2 := Bmp.Height - 1;
 
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
 
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
 
if ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
else if ifx > Bmp.Width - 1 then
ifx := ifx mod Bmp.Width;
if ify < 0 then
ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
else if ify > Bmp.Height - 1 then
ify := ify mod Bmp.Height;
 
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
if ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
_Twist(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoTrace(Amount: Integer);
procedure Trace(src: TDIB; intensity: Integer);
var
x, y, i: Integer;
P1, P2, P3, P4: PByteArray;
tb, TraceB: byte;
hasb: Boolean;
bitmap: TDIB;
begin
bitmap := TDIB.create;
bitmap.width := src.width;
bitmap.height := src.height;
bitmap.canvas.draw(0, 0, src);
bitmap.BitCount := 8;
src.BitCount := 24;
hasb := false;
TraceB := $00; tb := 0;
for i := 1 to Intensity do
begin
for y := 0 to BitMap.height - 2 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y + 1];
P3 := src.scanline[y];
P4 := src.scanline[y + 1];
x := 0;
repeat
if p1[x] <> p1[x + 1] then
begin
if not hasb then
begin
tb := p1[x + 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p3[(x + 1) * 3] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
end;
end;
end;
if p1[x] <> p2[x] then
begin
if not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
inc(x);
until x >= (BitMap.width - 2);
end;
if i > 1 then
for y := BitMap.height - 1 downto 1 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y - 1];
P3 := src.scanline[y];
P4 := src.scanline[y - 1];
x := Bitmap.width - 1;
repeat
if p1[x] <> p1[x - 1] then
begin
if not hasb then
begin
tb := p1[x - 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p3[(x - 1) * 3] := TraceB;
p3[(x - 1) * 3 + 1] := TraceB;
p3[(x - 1) * 3 + 2] := TraceB;
end;
end;
end;
if p1[x] <> p2[x] then
begin
if not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
dec(x);
until x <= 1;
end;
end;
bitmap.free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Trace(BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSplitlight(Amount: Integer);
procedure Splitlight(var clip: TDIB; amount: Integer);
var
x, y, i: Integer;
p1: pbytearray;
 
function sinpixs(a: Integer): Integer;
begin
result := variant(sin(a / 255 * pi / 2) * 255);
end;
begin
for i := 1 to amount do
for y := 0 to clip.height - 1 do
begin
p1 := clip.scanline[y];
for x := 0 to clip.width - 1 do
begin
p1[x * 3] := sinpixs(p1[x * 3]);
p1[x * 3 + 1] := sinpixs(p1[x * 3 + 1]);
p1[x * 3 + 2] := sinpixs(p1[x * 3 + 2]);
end;
end;
end;
var BB1 {,BB2}: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
// BB2 := TDIB.Create;
// BB2.BitCount := 24;
// BB2.Assign (BB1);
Splitlight(BB1, Amount);
Self.Assign(BB1);
BB1.Free;
// BB2.Free;
end;
 
procedure TDIB.DoTile(Amount: Integer);
procedure SmoothResize(var Src, Dst: TDIB);
var
x, y, xP, yP,
yP2, xP2: Integer;
Read, Read2: PByteArray;
t, z, z2, iz2: Integer;
pc: PBytearray;
w1, w2, w3, w4: Integer;
Col1r, col1g, col1b, Col2r, col2g, col2b: byte;
begin
xP2 := ((src.Width - 1) shl 15) div Dst.Width;
yP2 := ((src.Height - 1) shl 15) div Dst.Height;
yP := 0;
for y := 0 to Dst.Height - 1 do
begin
xP := 0;
Read := src.ScanLine[yP shr 15];
if yP shr 16 < src.Height - 1 then
Read2 := src.ScanLine[yP shr 15 + 1]
else
Read2 := src.ScanLine[yP shr 15];
pc := Dst.scanline[y];
z2 := yP and $7FFF;
iz2 := $8000 - z2;
for x := 0 to Dst.Width - 1 do
begin
t := xP shr 15;
Col1r := Read[t * 3];
Col1g := Read[t * 3 + 1];
Col1b := Read[t * 3 + 2];
Col2r := Read2[t * 3];
Col2g := Read2[t * 3 + 1];
Col2b := Read2[t * 3 + 2];
z := xP and $7FFF;
w2 := (z * iz2) shr 15;
w1 := iz2 - w2;
w4 := (z * z2) shr 15;
w3 := z2 - w4;
pc[x * 3 + 2] :=
(Col1b * w1 + Read[(t + 1) * 3 + 2] * w2 +
Col2b * w3 + Read2[(t + 1) * 3 + 2] * w4) shr 15;
pc[x * 3 + 1] :=
(Col1g * w1 + Read[(t + 1) * 3 + 1] * w2 +
Col2g * w3 + Read2[(t + 1) * 3 + 1] * w4) shr 15;
pc[x * 3] :=
(Col1r * w1 + Read2[(t + 1) * 3] * w2 +
Col2r * w3 + Read2[(t + 1) * 3] * w4) shr 15;
Inc(xP, xP2);
end;
Inc(yP, yP2);
end;
end;
procedure Tile(src, dst: TDIB; amount: Integer);
var
w, h, w2, h2, i, j: Integer;
bm: TDIB;
begin
w := src.width;
h := src.height;
dst.width := w;
dst.height := h;
dst.Canvas.draw(0, 0, src);
if (amount <= 0) or ((w div amount) < 5) or ((h div amount) < 5) then exit;
h2 := h div amount;
w2 := w div amount;
bm := TDIB.create;
bm.width := w2;
bm.height := h2;
bm.BitCount := 24;
smoothresize(src, bm);
for j := 0 to amount - 1 do
for i := 0 to amount - 1 do
dst.canvas.Draw(i * w2, j * h2, bm);
bm.free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Tile(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSpotLight(Amount: Integer; Spot: TRect);
procedure SpotLight(var src: TDIB; Amount: Integer; Spot: TRect);
var
bm, z: TDIB;
w, h: Integer;
begin
z := TDIB.Create;
try
z.SetSize(src.Width, src.Height, 24);
z.DrawTo(src, 0, 0, src.Width, src.Height, 0, 0);
w := z.Width;
h := z.Height;
bm := TDIB.create;
try
bm.Width := w;
bm.Height := h;
bm.Canvas.Brush.color := clblack;
bm.Canvas.FillRect(rect(0, 0, w, h));
bm.Canvas.Brush.Color := clwhite;
bm.Canvas.Ellipse(Spot.left, spot.top, spot.right, spot.bottom);
bm.Transparent := true;
z.Canvas.CopyMode := cmSrcAnd; {as transparentcolor for white}
z.Canvas.Draw(0, 0, src);
z.Canvas.Draw(0, 0, bm);
src.Darkness(Amount);
src.Canvas.CopyMode := cmSrcPaint;
src.DrawTransparent(z, 0, 0, z.Width, z.Height, 0, 0, clBlack);
finally
bm.Free;
end;
finally
z.Free
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
SpotLight(BB2, Amount, Spot);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoEmboss;
procedure Emboss(var Bmp: TDIB);
var
x, y: Integer;
p1, p2: Pbytearray;
begin
for y := 0 to Bmp.Height - 2 do
begin
p1 := bmp.scanline[y];
p2 := bmp.scanline[y + 1];
for x := 0 to Bmp.Width - 4 do
begin
p1[x * 3] := (p1[x * 3] + (p2[(x + 3) * 3] xor $FF)) shr 1;
p1[x * 3 + 1] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] xor $FF)) shr 1;
p1[x * 3 + 2] := (p1[x * 3 + 2] + (p2[(x + 3) * 3 + 2] xor $FF)) shr 1;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Emboss(BB2);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSolorize(Amount: Integer);
procedure Solorize(src, dst: TDIB; amount: Integer);
var
w, h, x, y: Integer;
ps, pd: pbytearray;
c: Integer;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
dst.BitCount := 24;
for y := 0 to h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
for x := 0 to w - 1 do
begin
c := (ps[x * 3] + ps[x * 3 + 1] + ps[x * 3 + 2]) div 3;
if c > amount then
begin
pd[x * 3] := 255 - ps[x * 3];
pd[x * 3 + 1] := 255 - ps[x * 3 + 1];
pd[x * 3 + 2] := 255 - ps[x * 3 + 2];
end
else
begin
pd[x * 3] := ps[x * 3];
pd[x * 3 + 1] := ps[x * 3 + 1];
pd[x * 3 + 2] := ps[x * 3 + 2];
end;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Solorize(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoPosterize(Amount: Integer);
procedure Posterize(src, dst: TDIB; amount: Integer);
var
w, h, x, y: Integer;
ps, pd: pbytearray;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
dst.BitCount := 24;
for y := 0 to h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
for x := 0 to w - 1 do
begin
pd[x * 3] := round(ps[x * 3] / amount) * amount;
pd[x * 3 + 1] := round(ps[x * 3 + 1] / amount) * amount;
pd[x * 3 + 2] := round(ps[x * 3 + 2] / amount) * amount;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Posterize(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoBrightness(Amount: Integer);
procedure Brightness(src, dst: TDIB; level: Integer);
const
MaxPixelCount = 32768;
type
pRGBArray = ^TRGBArray;
TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
var
i, j, value: Integer;
OrigRow, DestRow: pRGBArray;
begin
// get brightness increment value
value := level;
src.BitCount := 24;
dst.BitCount := 24;
// for each row of pixels
for i := 0 to src.Height - 1 do
begin
OrigRow := src.ScanLine[i];
DestRow := dst.ScanLine[i];
// for each pixel in row
for j := 0 to src.Width - 1 do
begin
// add brightness value to pixel's RGB values
if value > 0 then
begin
// RGB values must be less than 256
DestRow[j].rgbtRed := Min(255, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Min(255, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Min(255, OrigRow[j].rgbtBlue + value);
end
else
begin
// RGB values must be greater or equal than 0
DestRow[j].rgbtRed := Max(0, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Max(0, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Max(0, OrigRow[j].rgbtBlue + value);
end;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Brightness(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
procedure Resample(Src, Dst: TDIB; filtertype: TFilterTypeResample; fwidth: single);
// -----------------------------------------------------------------------------
//
// Filter functions
//
// -----------------------------------------------------------------------------
 
// Hermite filter
function HermiteFilter(Value: Single): Single;
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
else
Result := 0.0;
end;
 
// Box filter
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
function BoxFilter(Value: Single): Single;
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;
 
// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
function TriangleFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := 1.0 - Value
else
Result := 0.0;
end;
 
// Bell filter
function BellFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 0.5) then
Result := 0.75 - Sqr(Value)
else
if (Value < 1.5) then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
end
else
Result := 0.0;
end;
 
// B-spline filter
function SplineFilter(Value: Single): Single;
var
tt: single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
begin
tt := Sqr(Value);
Result := 0.5 * tt * Value - tt + 2.0 / 3.0;
end
else
if (Value < 2.0) then
begin
Value := 2.0 - Value;
Result := 1.0 / 6.0 * Sqr(Value) * Value;
end
else
Result := 0.0;
end;
 
// Lanczos3 filter
function Lanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
begin
if (Value <> 0.0) then
begin
Value := Value * Pi;
Result := sin(Value) / Value
end
else
Result := 1.0;
end;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 3.0) then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;
 
function MitchellFilter(Value: Single): Single;
const
B = (1.0 / 3.0);
C = (1.0 / 3.0);
var
tt: single;
begin
if (Value < 0.0) then
Value := -Value;
tt := Sqr(Value);
if (Value < 1.0) then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
+ ((-18.0 + 12.0 * B + 6.0 * C) * tt)
+ (6.0 - 2 * B));
Result := Value / 6.0;
end
else
if (Value < 2.0) then
begin
Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
+ ((6.0 * B + 30.0 * C) * tt)
+ ((-12.0 * B - 48.0 * C) * Value)
+ (8.0 * B + 24 * C));
Result := Value / 6.0;
end
else
Result := 0.0;
end;
 
// -----------------------------------------------------------------------------
//
// Interpolator
//
// -----------------------------------------------------------------------------
type
// Contributor for a pixel
TContributor = record
pixel: Integer; // Source pixel
weight: single; // Pixel weight
end;
 
TContributorList = array[0..0] of TContributor;
PContributorList = ^TContributorList;
 
// List of source pixels contributing to a destination pixel
TCList = record
n: Integer;
p: PContributorList;
end;
 
TCListList = array[0..0] of TCList;
PCListList = ^TCListList;
 
TRGB = packed record
r, g, b: single;
end;
 
// Physical bitmap pixel
TColorRGB = packed record
r, g, b: BYTE;
end;
PColorRGB = ^TColorRGB;
 
// Physical bitmap scanline (row)
TRGBList = packed array[0..0] of TColorRGB;
PRGBList = ^TRGBList;
 
var
xscale, yscale: single; // Zoom scale factors
i, j, k: Integer; // Loop variables
center: single; // Filter calculation variables
width, fscale, weight: single; // Filter calculation variables
left, right: Integer; // Filter calculation variables
n: Integer; // Pixel number
Work: TDIB;
contrib: PCListList;
rgb: TRGB;
color: TColorRGB;
{$IFDEF USE_SCANLINE}
SourceLine,
DestLine: PRGBList;
SourcePixel,
DestPixel: PColorRGB;
Delta,
DestDelta: Integer;
{$ENDIF}
SrcWidth,
SrcHeight,
DstWidth,
DstHeight: Integer;
 
function Color2RGB(Color: TColor): TColorRGB;
begin
Result.r := Color and $000000FF;
Result.g := (Color and $0000FF00) shr 8;
Result.b := (Color and $00FF0000) shr 16;
end;
 
function RGB2Color(Color: TColorRGB): TColor;
begin
Result := Color.r or (Color.g shl 8) or (Color.b shl 16);
end;
 
begin
DstWidth := Dst.Width;
DstHeight := Dst.Height;
SrcWidth := Src.Width;
SrcHeight := Src.Height;
if (SrcWidth < 1) or (SrcHeight < 1) then
raise Exception.Create('Source bitmap too small');
 
// Create intermediate image to hold horizontal zoom
Work := TDIB.Create;
try
Work.Height := SrcHeight;
Work.Width := DstWidth;
// xscale := DstWidth / SrcWidth;
// yscale := DstHeight / SrcHeight;
// Improvement suggested by David Ullrich:
if (SrcWidth = 1) then
xscale := DstWidth / SrcWidth
else
xscale := (DstWidth - 1) / (SrcWidth - 1);
if (SrcHeight = 1) then
yscale := DstHeight / SrcHeight
else
yscale := (DstHeight - 1) / (SrcHeight - 1);
// This implementation only works on 24-bit images because it uses
// TDIB.Scanline
{$IFDEF USE_SCANLINE}
//Src.PixelFormat := pf24bit;
Src.BitCount := 24;
//Dst.PixelFormat := Src.PixelFormat;
dst.BitCount := 24;
//Work.PixelFormat := Src.PixelFormat;
work.BitCount := 24;
{$ENDIF}
 
// --------------------------------------------
// Pre-calculate filter contributions for a row
// -----------------------------------------------
GetMem(contrib, DstWidth * sizeof(TCList));
// Horizontal sub-sampling
// Scales from bigger to smaller width
if (xscale < 1.0) then
begin
width := fwidth / xscale;
fscale := 1.0 / xscale;
for i := 0 to DstWidth - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end
else
// Horizontal super-sampling
// Scales from smaller to bigger width
begin
for i := 0 to DstWidth - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter(center - j);
ftrTriangle: weight := trianglefilter(center - j);
ftrHermite: weight := hermitefilter(center - j);
ftrBell: weight := bellfilter(center - j);
ftrBSpline: weight := splinefilter(center - j);
ftrLanczos3: weight := Lanczos3filter(center - j);
ftrMitchell: weight := Mitchellfilter(center - j);
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end;
 
// ----------------------------------------------------
// Apply filter to sample horizontally from Src to Work
// ----------------------------------------------------
for k := 0 to SrcHeight - 1 do
begin
{$IFDEF USE_SCANLINE}
SourceLine := Src.ScanLine[k];
DestPixel := Work.ScanLine[k];
{$ENDIF}
for i := 0 to DstWidth - 1 do
begin
rgb.r := 0.0;
rgb.g := 0.0;
rgb.b := 0.0;
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := SourceLine^[contrib^[i].p^[j].pixel];
{$ELSE}
color := Color2RGB(Src.Canvas.Pixels[contrib^[i].p^[j].pixel, k]);
{$ENDIF}
weight := contrib^[i].p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
if (rgb.r > 255.0) then
color.r := 255
else if (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
if (rgb.g > 255.0) then
color.g := 255
else if (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
if (rgb.b > 255.0) then
color.b := 255
else if (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
// Set new pixel value
DestPixel^ := color;
// Move on to next column
inc(DestPixel);
{$ELSE}
Work.Canvas.Pixels[i, k] := RGB2Color(color);
{$ENDIF}
end;
end;
 
// Free the memory allocated for horizontal filter weights
for i := 0 to DstWidth - 1 do
FreeMem(contrib^[i].p);
 
FreeMem(contrib);
 
// -----------------------------------------------
// Pre-calculate filter contributions for a column
// -----------------------------------------------
GetMem(contrib, DstHeight * sizeof(TCList));
// Vertical sub-sampling
// Scales from bigger to smaller height
if (yscale < 1.0) then
begin
width := fwidth / yscale;
fscale := 1.0 / yscale;
for i := 0 to DstHeight - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end
end
else
// Vertical super-sampling
// Scales from smaller to bigger height
begin
for i := 0 to DstHeight - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter(center - j);
ftrTriangle: weight := trianglefilter(center - j);
ftrHermite: weight := hermitefilter(center - j);
ftrBell: weight := bellfilter(center - j);
ftrBSpline: weight := splinefilter(center - j);
ftrLanczos3: weight := Lanczos3filter(center - j);
ftrMitchell: weight := Mitchellfilter(center - j);
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end;
 
// --------------------------------------------------
// Apply filter to sample vertically from Work to Dst
// --------------------------------------------------
{$IFDEF USE_SCANLINE}
SourceLine := Work.ScanLine[0];
Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
DestLine := Dst.ScanLine[0];
DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine);
{$ENDIF}
for k := 0 to DstWidth - 1 do
begin
{$IFDEF USE_SCANLINE}
DestPixel := pointer(DestLine);
{$ENDIF}
for i := 0 to DstHeight - 1 do
begin
rgb.r := 0;
rgb.g := 0;
rgb.b := 0;
// weight := 0.0;
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := PColorRGB(Integer(SourceLine) + contrib^[i].p^[j].pixel * Delta)^;
{$ELSE}
color := Color2RGB(Work.Canvas.Pixels[k, contrib^[i].p^[j].pixel]);
{$ENDIF}
weight := contrib^[i].p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
if (rgb.r > 255.0) then
color.r := 255
else if (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
if (rgb.g > 255.0) then
color.g := 255
else if (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
if (rgb.b > 255.0) then
color.b := 255
else if (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
DestPixel^ := color;
inc(Integer(DestPixel), DestDelta);
{$ELSE}
Dst.Canvas.Pixels[k, i] := RGB2Color(color);
{$ENDIF}
end;
{$IFDEF USE_SCANLINE}
Inc(SourceLine, 1);
Inc(DestLine, 1);
{$ENDIF}
end;
 
// Free the memory allocated for vertical filter weights
for i := 0 to DstHeight - 1 do
FreeMem(contrib^[i].p);
 
FreeMem(contrib);
 
finally
Work.Free;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.SetSize(AmountX, AmountY, 24);
Resample(BB1, BB2, TypeResample, DefaultFilterRadius[TypeResample]);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoColorize(ForeColor, BackColor: TColor);
procedure Colorize(src, dst: TDIB; iForeColor, iBackColor: TColor; iDither: Boolean{$IFDEF VER4UP} = False{$ENDIF});
{for monochromatic picture change colors}
procedure InvertBitmap(Bmp: TDIB);
begin
Bmp.Canvas.CopyMode := cmDstInvert;
Bmp.Canvas.CopyRect(rect(0, 0, Bmp.Width, Bmp.Height),
Bmp.Canvas, rect(0, 0, Bmp.Width, Bmp.Height));
end;
var
fForeColor: TColor;
fForeDither: Boolean;
lTempBitmap: TDIB;
lTempBitmap2: TDIB;
lDitherBitmap: TDIB;
lCRect: TRect;
x, y, w, h: Integer;
begin
{--}
//fColor := iBackColor; ;
fForeColor := iForeColor;
fForeDither := iDither;
w := src.Width;
h := src.Height;
lDitherBitmap := nil;
lTempBitmap := TDIB.Create;
lTempBitmap.SetSize(w, h, 24);
lTempBitmap2 := TDIB.Create;
lTempBitmap2.SetSize(w, h, 24);
lCRect := rect(0, 0, w, h);
with lTempBitmap.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := iBackColor;
FillRect(lCRect);
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
CopyMode := cmSrcPaint;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(lTempBitmap);
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
end;
with lTempBitmap2.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clBlack;
FillRect(lCRect);
if fForeDither then
begin
InvertBitmap(src);
lDitherBitmap := TDIB.Create;
lDitherBitmap.SetSize(8, 8, 24);
with lDitherBitmap.Canvas do
begin
for x := 0 to 7 do
for y := 0 to 7 do
if ((x mod 2 = 0) and (y mod 2 > 0)) or ((x mod 2 > 0) and (y mod 2 = 0)) then
pixels[x, y] := fForeColor
else
pixels[x, y] := iBackColor;
end;
Brush.Bitmap.Assign(lDitherBitmap);
end
else
begin
Brush.Style := bsSolid;
Brush.Color := fForeColor;
end;
if not fForeDither then
InvertBitmap(src);
CopyMode := cmPatPaint;
CopyRect(lCRect, src.Canvas, lCRect);
if fForeDither then
if Assigned(lDitherBitmap) then
lDitherBitmap.Free;
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
end;
lTempBitmap.Canvas.CopyMode := cmSrcInvert;
lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
InvertBitmap(src);
lTempBitmap.Canvas.CopyMode := cmSrcErase;
lTempBitmap.Canvas.Copyrect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
lTempBitmap.Canvas.CopyMode := cmSrcInvert;
lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
InvertBitmap(lTempBitmap);
InvertBitmap(src);
dst.Assign(lTempBitmap);
lTempBitmap.Free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
Colorize(BB1, BB2, ForeColor, BackColor{$IFNDEF VER4UP}, False{$ENDIF});
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
{ procedure for special purpose }
 
procedure TDIB.FadeOut(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
PUSH EDI
MOV ESI, P1
MOV EDI, P2
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
@@1:
MOV AL, Step
MOV AH, [ESI]
CMP AL, AH
JA @@2
MOV AL, AH
@@2:
MOV [EDI], AL
INC ESI
INC EDI
DEC ECX
JNZ @@1
POP EDI
POP ESI
end;
end;
 
procedure TDIB.DoZoom(DIB2: TDIB; ZoomRatio: Real);
var
P1, P2: PByteArray;
W, H: Integer;
x, y: Integer;
xr, yr, xstep, ystep: real;
xstart: real;
begin
W := WidthBytes;
H := Height;
xstart := (W - (W * ZoomRatio)) / 2;
 
xr := xstart;
yr := (H - (H * ZoomRatio)) / 2;
xstep := ZoomRatio;
ystep := ZoomRatio;
 
for y := 1 to Height - 1 do
begin
P2 := DIB2.ScanLine[y];
if (yr >= 0) and (yr <= H) then
begin
P1 := ScanLine[Trunc(yr)];
for x := 1 to Width - 1 do
begin
if (xr >= 0) and (xr <= W) then
begin
P2[x] := P1[Trunc(xr)];
end
else
begin
P2[x] := 0;
end;
xr := xr + xstep;
end;
end
else
begin
for x := 1 to Width - 1 do
begin
P2[x] := 0;
end;
end;
xr := xstart;
yr := yr + ystep;
end;
end;
 
procedure TDIB.DoBlur(DIB2: TDIB);
var
P1, P2: PByteArray;
W: Integer;
x, y: Integer;
begin
W := WidthBytes;
for y := 1 to Height - 1 do
begin
P1 := ScanLine[y];
P2 := DIB2.ScanLine[y];
for x := 1 to Width - 1 do
begin
P2[x] := (P1[x] + P1[x - 1] + P1[x + 1] + P1[x + W] + P1[x - W]) div 5;
end;
end;
end;
 
procedure TDIB.FadeIn(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
PUSH EDI
MOV ESI, P1
MOV EDI, P2
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
@@1:
MOV AL, Step
MOV AH, [ESI]
CMP AL, AH
JB @@2
MOV AL, AH
@@2:
MOV [EDI], AL
INC ESI
INC EDI
DEC ECX
JNZ @@1
POP EDI
POP ESI
end;
end;
 
procedure TDIB.FillDIB8(Color: Byte);
var
P: PByteArray;
W, H: Integer;
begin
P := ScanLine[Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
MOV ESI, P
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
MOV AL, Color
@@1:
MOV [ESI], AL
INC ESI
DEC ECX
JNZ @@1
POP ESI
end;
end;
 
procedure TDIB.DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
var
p, p2: PByteArray;
x, y, x2, y2, angled: Integer;
cosy, siny: real;
begin
angled := 384 + Angle;
for y := 0 to Height - 1 do
begin
p := DIB1.ScanLine[y];
cosy := (y - cY) * dcos(angled and $1FF);
siny := (y - cY) * dsin(angled and $1FF);
for x := 0 to Width - 1 do
begin
x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
case bitcount of
8:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
p2 := ScanLine[y2];
p[x] := p2[Width - x2];
end
else
begin
if p[x] > 4 then
p[x] := p[x] - 4
else
p[x] := 0;
end;
end;
16:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
PWordArray(p2) := ScanLine[y2];
PWordArray(p)[x] := PWordArray(p2)[Width - x2];
end
else
begin
if PWordArray(p)[x] > 4 then
PWordArray(p)[x] := PWordArray(p)[x] - 4
else
PWordArray(p)[x] := 0;
end;
end;
24:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
P3ByteArray(p2) := ScanLine[y2];
P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
end
else
begin
if P3ByteArray(p)[x][0] > 4 then
P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 4
else if P3ByteArray(p)[x][1] > 4 then
P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 4
else if P3ByteArray(p)[x][2] > 4 then
P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 4
else
begin
P3ByteArray(p)[x][0] := 0;
P3ByteArray(p)[x][1] := 0;
P3ByteArray(p)[x][2] := 0;
end;
end;
end;
32: begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
plongarray(p2) := ScanLine[y2];
plongarray(p)[x] := plongarray(p2)[Width - x2];
end
else
begin
if plongarray(p)[x] > 4 then
plongarray(p)[x] := plongarray(p)[x] - 4
else
plongarray(p)[x] := 0;
end;
end;
end
end;
end;
end;
 
function TDIB.Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
function ColorToRGBTriple(const Color: TColor): TRGBTriple;
begin
with RESULT do
begin
rgbtRed := GetRValue(Color);
rgbtGreen := GetGValue(Color);
rgbtBlue := GetBValue(Color)
end
end {ColorToRGBTriple};
 
function TestQuad(T: T3Byte; Color: Integer): Boolean;
begin
Result := (T[0] > GetRValue(Color)) and
(T[1] > GetGValue(Color)) and
(T[2] > GetBValue(Color))
end;
var
p0, p, p2: PByteArray;
x, y, c: Integer;
z: Integer;
begin
if SprayInit then
begin
DIB.Assign(Self);
{ Spray seeds }
for c := 0 to AmountSpray do
begin
DIB.Pixels[Random(Width - 1), Random(Height - 1)] := 0;
end;
end;
Result := True; {all is black}
for y := 0 to DIB.Height - 1 do
begin
p := DIB.ScanLine[y];
for x := 0 to DIB.Width - 1 do
begin
case bitcount of
8:
begin
if p[x] < 16 then
begin
if p[x] > 0 then Result := False;
if y > 0 then
begin
p0 := DIB.ScanLine[y - 1];
if p0[x] > 4 then
p0[x] := p0[x] - 4
else
p0[x] := 0;
if x > 0 then
if p0[x - 1] > 2 then
p0[x - 1] := p0[x - 1] - 2
else
p0[x - 1] := 0;
if x < (DIB.Width - 1) then
if p0[x + 1] > 2 then
p0[x + 1] := p0[x + 1] - 2
else
p0[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
p2 := DIB.ScanLine[y + 1];
if p2[x] > 4 then
p2[x] := p2[x] - 4
else
p2[x] := 0;
if x > 0 then
if p2[x - 1] > 2 then
p2[x - 1] := p2[x - 1] - 2
else
p2[x - 1] := 0;
if x < (DIB.Width - 1) then
if p2[x + 1] > 2 then
p2[x + 1] := p2[x + 1] - 2
else
p2[x + 1] := 0;
end;
if p[x] > 8 then
p[x] := p[x] - 8
else
p[x] := 0;
if x > 0 then
if p[x - 1] > 4 then
p[x - 1] := p[x - 1] - 4
else
p[x - 1] := 0;
if x < (DIB.Width - 1) then
if p[x + 1] > 4 then
p[x + 1] := p[x + 1] - 4
else
p[x + 1] := 0;
end;
end;
16:
begin
if pwordarray(p)[x] < 16 then
begin
if pwordarray(p)[x] > 0 then Result := False;
if y > 0 then
begin
pwordarray(p0) := DIB.ScanLine[y - 1];
if pwordarray(p0)[x] > 4 then
pwordarray(p0)[x] := pwordarray(p0)[x] - 4
else
pwordarray(p0)[x] := 0;
if x > 0 then
if pwordarray(p0)[x - 1] > 2 then
pwordarray(p0)[x - 1] := pwordarray(p0)[x - 1] - 2
else
pwordarray(p0)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p0)[x + 1] > 2 then
pwordarray(p0)[x + 1] := pwordarray(p0)[x + 1] - 2
else
pwordarray(p0)[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
pwordarray(p2) := DIB.ScanLine[y + 1];
if pwordarray(p2)[x] > 4 then
pwordarray(p2)[x] := pwordarray(p2)[x] - 4
else
pwordarray(p2)[x] := 0;
if x > 0 then
if pwordarray(p2)[x - 1] > 2 then
pwordarray(p2)[x - 1] := pwordarray(p2)[x - 1] - 2
else
pwordarray(p2)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p2)[x + 1] > 2 then
pwordarray(p2)[x + 1] := pwordarray(p2)[x + 1] - 2
else
pwordarray(p2)[x + 1] := 0;
end;
if pwordarray(p)[x] > 8 then
pwordarray(p)[x] := pwordarray(p)[x] - 8
else
pwordarray(p)[x] := 0;
if x > 0 then
if pwordarray(p)[x - 1] > 4 then
pwordarray(p)[x - 1] := pwordarray(p)[x - 1] - 4
else
pwordarray(p)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p)[x + 1] > 4 then
pwordarray(p)[x + 1] := pwordarray(p)[x + 1] - 4
else
pwordarray(p)[x + 1] := 0;
end;
end;
24:
begin
if not TestQuad(P3ByteArray(p)[x], 16) then
begin
if TestQuad(P3ByteArray(p)[x], 0) then Result := False;
if y > 0 then
begin
P3ByteArray(p0) := DIB.ScanLine[y - 1];
if TestQuad(P3ByteArray(p0)[x], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x][z] > 4 then
P3ByteArray(p0)[x][z] := P3ByteArray(p0)[x][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p0)[x - 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x - 1][z] > 2 then
P3ByteArray(p0)[x - 1][z] := P3ByteArray(p0)[x - 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p0)[x + 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x + 1][z] > 2 then
P3ByteArray(p0)[x + 1][z] := P3ByteArray(p0)[x + 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x + 1][z] := 0;
end;
if y < (DIB.Height - 1) then
begin
P3ByteArray(p2) := DIB.ScanLine[y + 1];
if TestQuad(P3ByteArray(p2)[x], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x][z] > 4 then
P3ByteArray(p2)[x][z] := P3ByteArray(p2)[x][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p2)[x - 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x - 1][z] > 2 then
P3ByteArray(p2)[x - 1][z] := P3ByteArray(p2)[x - 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p2)[x + 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x + 1][z] > 2 then
P3ByteArray(p2)[x + 1][z] := P3ByteArray(p2)[x + 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x + 1][z] := 0;
end;
if TestQuad(P3ByteArray(p)[x], 8) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x][z] > 8 then
P3ByteArray(p)[x][z] := P3ByteArray(p)[x][z] - 8
end
else
for z := 0 to 2 do
P3ByteArray(p)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p)[x - 1], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x - 1][z] > 4 then
P3ByteArray(p)[x - 1][z] := P3ByteArray(p)[x - 1][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p)[x + 1], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x + 1][z] > 4 then
P3ByteArray(p)[x + 1][z] := P3ByteArray(p)[x + 1][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p)[x + 1][z] := 0;
end;
end;
32:
begin
if plongarray(p)[x] < 16 then
begin
if plongarray(p)[x] > 0 then Result := False;
if y > 0 then
begin
plongarray(p0) := DIB.ScanLine[y - 1];
if plongarray(p0)[x] > 4 then
plongarray(p0)[x] := plongarray(p0)[x] - 4
else
plongarray(p0)[x] := 0;
if x > 0 then
if plongarray(p0)[x - 1] > 2 then
plongarray(p0)[x - 1] := plongarray(p0)[x - 1] - 2
else
plongarray(p0)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p0)[x + 1] > 2 then
plongarray(p0)[x + 1] := plongarray(p0)[x + 1] - 2
else
plongarray(p0)[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
plongarray(p2) := DIB.ScanLine[y + 1];
if plongarray(p2)[x] > 4 then
plongarray(p2)[x] := plongarray(p2)[x] - 4
else
plongarray(p2)[x] := 0;
if x > 0 then
if plongarray(p2)[x - 1] > 2 then
plongarray(p2)[x - 1] := plongarray(p2)[x - 1] - 2
else
plongarray(p2)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p2)[x + 1] > 2 then
plongarray(p2)[x + 1] := plongarray(p2)[x + 1] - 2
else
plongarray(p2)[x + 1] := 0;
end;
if plongarray(p)[x] > 8 then
plongarray(p)[x] := plongarray(p)[x] - 8
else
plongarray(p)[x] := 0;
if x > 0 then
if plongarray(p)[x - 1] > 4 then
plongarray(p)[x - 1] := plongarray(p)[x - 1] - 4
else
plongarray(p)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p)[x + 1] > 4 then
plongarray(p)[x + 1] := plongarray(p)[x + 1] - 4
else
plongarray(p)[x + 1] := 0;
end;
end;
end {case};
end;
end;
end;
 
procedure TDIB.Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
var
p, p2: PByteArray;
x, y, x2, y2, angled, ysqr: Integer;
actdist, dist, cosy, siny: real;
begin
dist := Factor * sqrt(sqr(cX) + sqr(cY));
for y := 0 to DIB1.Height - 1 do
begin
p := DIB1.ScanLine[y];
ysqr := sqr(y - cY);
for x := 0 to (DIB1.Width) - 1 do
begin
actdist := (sqrt((sqr(x - cX) + ysqr)) / dist);
if dt = dtSlow then
actdist := dsin((Trunc(actdist * 1024)) and $1FF);
angled := 384 + Trunc((actdist) * Angle);
 
cosy := (y - cY) * dcos(angled and $1FF);
siny := (y - cY) * dsin(angled and $1FF);
 
x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
case bitcount of
8:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
p2 := ScanLine[y2];
p[x] := p2[Width - x2];
end
else
begin
if p[x] > 2 then
p[x] := p[x] - 2
else
p[x] := 0;
end;
end;
16:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
pwordarray(p2) := ScanLine[y2];
pwordarray(p)[x] := pwordarray(p2)[Width - x2];
end
else
begin
if pwordarray(p)[x] > 2 then
pwordarray(p)[x] := pwordarray(p)[x] - 2
else
pwordarray(p)[x] := 0;
end;
end;
24:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
P3ByteArray(p2) := ScanLine[y2];
P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
end
else
begin
if P3ByteArray(p)[x][0] > 2 then
P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 2
else if P3ByteArray(p)[x][1] > 2 then
P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 2
else if P3ByteArray(p)[x][2] > 2 then
P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 2
else
begin
P3ByteArray(p)[x][0] := 0;
P3ByteArray(p)[x][1] := 0;
P3ByteArray(p)[x][2] := 0;
end;
end;
end;
32:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
plongarray(p2) := ScanLine[y2];
plongarray(p)[x] := plongarray(p2)[Width - x2];
end
else
begin
if p[x] > 2 then
plongarray(p)[x] := plongarray(p)[x] - 2
else
plongarray(p)[x] := 0;
end;
end;
end {case}
end;
end;
end;
 
procedure TDIB.AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor);
//anti-aliased line using the Wu algorithm by Peter Bone
var
dX, dY, X, Y, start, finish: Integer;
LM, LR: Integer;
dxi, dyi, dydxi: Integer;
P: PLines;
R, G, B: byte;
begin
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
dX := abs(x2 - x1); // Calculate deltax and deltay for initialisation
dY := abs(y2 - y1);
if (dX = 0) or (dY = 0) then
begin
Canvas.Pen.Color := (B shl 16) + (G shl 8) + R;
Canvas.MoveTo(x1, y1);
Canvas.LineTo(x2, y2);
exit;
end;
if dX > dY then
begin // horizontal or vertical
if y2 > y1 then // determine rise and run
dydxi := -dY shl 16 div dX
else
dydxi := dY shl 16 div dX;
if x2 < x1 then
begin
start := x2; // right to left
finish := x1;
dyi := y2 shl 16;
end
else
begin
start := x1; // left to right
finish := x2;
dyi := y1 shl 16;
dydxi := -dydxi; // inverse slope
end;
if finish >= Width then finish := Width - 1;
for X := start to finish do
begin
Y := dyi shr 16;
if (X < 0) or (Y < 0) or (Y > Height - 2) then
begin
Inc(dyi, dydxi);
Continue;
end;
LM := dyi - Y shl 16; // fractional part of dyi - in fixed-point
LR := 65536 - LM;
P := Scanline[Y];
P^[X].B := (B * LR + P^[X].B * LM) shr 16;
P^[X].G := (G * LR + P^[X].G * LM) shr 16;
P^[X].R := (R * LR + P^[X].R * LM) shr 16;
//Inc(Y);
P^[X].B := (B * LM + P^[X].B * LR) shr 16;
P^[X].G := (G * LM + P^[X].G * LR) shr 16;
P^[X].R := (R * LM + P^[X].R * LR) shr 16;
Inc(dyi, dydxi); // next point
end;
end
else
begin
if x2 > x1 then // determine rise and run
dydxi := -dX shl 16 div dY
else
dydxi := dX shl 16 div dY;
if y2 < y1 then
begin
start := y2; // right to left
finish := y1;
dxi := x2 shl 16;
end
else
begin
start := y1; // left to right
finish := y2;
dxi := x1 shl 16;
dydxi := -dydxi; // inverse slope
end;
if finish >= Height then finish := Height - 1;
for Y := start to finish do
begin
X := dxi shr 16;
if (Y < 0) or (X < 0) or (X > Width - 2) then
begin
Inc(dxi, dydxi);
Continue;
end;
LM := dxi - X shl 16;
LR := 65536 - LM;
P := Scanline[Y];
P^[X].B := (B * LR + P^[X].B * LM) shr 16;
P^[X].G := (G * LR + P^[X].G * LM) shr 16;
P^[X].R := (R * LR + P^[X].R * LM) shr 16;
Inc(X);
P^[X].B := (B * LM + P^[X].B * LR) shr 16;
P^[X].G := (G * LM + P^[X].G * LR) shr 16;
P^[X].R := (R * LM + P^[X].R * LR) shr 16;
Inc(dxi, dydxi); // next point
end;
end;
end;
 
function TDIB.GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
var F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
function CalcColorBytes(fb1, fb2: Byte): Byte;
begin
result := fb1;
if fb1 < fb2 then Result := FB1 + Trunc(F * (fb2 - fb1));
if fb1 > fb2 then Result := FB1 - Trunc(F * (fb1 - fb2));
end;
begin
if Pointvalue <= FromPoint then
begin
result := StartColor;
exit;
end;
if Pointvalue >= ToPoint then
begin
result := EndColor;
exit;
end;
F := (Pointvalue - FromPoint) / (ToPoint - FromPoint);
asm
mov EAX, Startcolor
cmp EAX, EndColor
je @@exit //when equal then exit
mov r1, AL
shr EAX,8
mov g1, AL
shr EAX,8
mov b1, AL
mov EAX, Endcolor
mov r2, AL
shr EAX,8
mov g2, AL
shr EAX,8
mov b2, AL
push ebp
mov AL, r1
mov DL, r2
call CalcColorBytes
pop ECX
push EBP
Mov r3, AL
mov DL, g2
mov AL, g1
call CalcColorBytes
pop ECX
push EBP
mov g3, Al
mov DL, B2
mov Al, B1
call CalcColorBytes
pop ECX
mov b3, AL
XOR EAX,EAX
mov AL, B3
shl EAX,8
mov AL, G3
shl EAX,8
mov AL, R3
@@Exit:
mov @result, EAX
end;
end;
 
procedure TDIB.ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry; iRadius: Word);
var
tempColor: TColor;
const
WavelengthMinimum = 380;
WavelengthMaximum = 780;
 
procedure SetColor(Color: TColor);
begin
Canvas.Pen.Color := Color;
Canvas.Brush.Color := Color;
tempColor := Color
end {SetColor};
 
function WL2RGB(const Wavelength: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
const
Gamma = 0.80;
IntensityMax = 255;
var
Red, Blue, Green, Factor: Double;
 
function Adjust(const Color, Factor: Double): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if Color = 0.0 then Result := 0
else Result := Round(IntensityMax * Power(Color * Factor, Gamma))
end {Adjust};
begin
case Trunc(Wavelength) of
380..439:
begin
Red := -(Wavelength - 440) / (440 - 380);
Green := 0.0;
Blue := 1.0
end;
440..489:
begin
Red := 0.0;
Green := (Wavelength - 440) / (490 - 440);
Blue := 1.0
end;
490..509:
begin
Red := 0.0;
Green := 1.0;
Blue := -(Wavelength - 510) / (510 - 490)
end;
510..579:
begin
Red := (Wavelength - 510) / (580 - 510);
Green := 1.0;
Blue := 0.0
end;
580..644:
begin
Red := 1.0;
Green := -(Wavelength - 645) / (645 - 580);
Blue := 0.0
end;
645..780:
begin
Red := 1.0;
Green := 0.0;
Blue := 0.0
end;
else
Red := 0.0;
Green := 0.0;
Blue := 0.0
end;
case Trunc(Wavelength) of
380..419: factor := 0.3 + 0.7 * (Wavelength - 380) / (420 - 380);
420..700: factor := 1.0;
701..780: factor := 0.3 + 0.7 * (780 - Wavelength) / (780 - 700)
else
factor := 0.0
end;
Result := RGB(Adjust(Red, Factor), Adjust(Green, Factor), Adjust(Blue, Factor));
end;
 
function Rainbow(const fraction: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (fraction < 0.0) or (fraction > 1.0) then Result := clBlack
else
Result := WL2RGB(WavelengthMinimum + Fraction * (WavelengthMaximum - WavelengthMinimum))
end {Raindbow};
 
function ColorInterpolate(const fraction: Double; const Color1, Color2: TColor): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
var
complement: Double;
R1, R2, G1, G2, B1, B2: BYTE;
begin
if fraction <= 0 then Result := Color1
else
if fraction >= 1.0 then Result := Color2
else
begin
R1 := GetRValue(Color1);
G1 := GetGValue(Color1);
B1 := GetBValue(Color1);
R2 := GetRValue(Color2);
G2 := GetGValue(Color2);
B2 := GetBValue(Color2);
complement := 1.0 - fraction;
Result := RGB(Round(complement * R1 + fraction * R2),
Round(complement * G1 + fraction * G2),
Round(complement * B1 + fraction * B2))
end
end {ColorInterpolate};
 
// Conversion utility routines
function ColorToRGBTriple(const Color: TColor): TRGBTriple; {$IFDEF VER9UP}inline;{$ENDIF}
begin
with Result do
begin
rgbtRed := GetRValue(Color);
rgbtGreen := GetGValue(Color);
rgbtBlue := GetBValue(Color)
end
end {ColorToRGBTriple};
 
function RGBTripleToColor(const Triple: TRGBTriple): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)
end {RGBTripleToColor};
// Bresenham's Line Algorithm. Byte, March 1988, pp. 249-253.
var
a, b, d, diag_inc, dXdg, dXndg, dYdg, dYndg, i, nDginc, nDswap, x, y: Integer;
begin {DrawLine}
x := iStart.X;
y := iStart.Y;
a := iEnd.X - iStart.X;
b := iEnd.Y - iStart.Y;
if a < 0 then
begin
a := -a;
dXdg := -1
end
else dXdg := 1;
if b < 0 then
begin
b := -b;
dYdg := -1
end
else dYdg := 1;
if a < b then
begin
nDswap := a;
a := b;
b := nDswap;
dXndg := 0;
dYndg := dYdg
end
else
begin
dXndg := dXdg;
dYndg := 0
end;
d := b + b - a;
nDginc := b + b;
diag_inc := b + b - a - a;
for i := 0 to a do
begin
case iPixelGeometry of
pgPoint:
case iColorStyle of
csSolid:
Canvas.Pixels[x, y] := tempColor;
csGradient:
Canvas.Pixels[x, y] := ColorInterpolate(i / a, iGradientFrom, iGradientTo);
csRainbow:
Canvas.Pixels[x, y] := Rainbow(i / a)
end;
pgCircular:
begin
case iColorStyle of
csSolid: ;
csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
csRainbow: SetColor(Rainbow(i / a))
end;
Canvas.Ellipse(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
end;
pgRectangular:
begin
case iColorStyle of
csSolid: ;
csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
csRainbow: SetColor(Rainbow(i / a))
end;
Canvas.Rectangle(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
end
end;
if d < 0 then
begin
Inc(x, dXndg);
Inc(y, dYndg);
Inc(d, nDginc);
end
else
begin
Inc(x, dXdg);
Inc(y, dYdg);
Inc(d, diag_inc);
end
end
end {Line};
 
procedure TDIB.DoNovaEffect(sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
// Copyright (c) 2000 by Keith Murray (kmurray@hotfreeware.com)
// All rights reserved.
// Adapted for DIB by JB.
type
PByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
PDoubleArray = ^TDoubleArray;
TDoubleArray = array[0..32767] of Double;
PIntegerArray = ^TIntegerArray;
TIntegerArray = array[0..32767] of Integer;
type
TProgressEvent = procedure(progress: Integer; message: string;
var cancel: Boolean) of object;
const
M_PI = 3.14159265358979323846;
RAND_MAX = 2147483647;
 
function Gauss: double;
const magnitude = 6;
var
sum: double;
i: Integer;
begin
sum := 0;
for i := 1 to magnitude do
sum := sum + (randgauss / 2147483647);
result := sum / magnitude;
end;
 
function Clamp(i, l, h: double): double; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
else
if i > h then
result := h
else
result := i;
end;
 
function IClamp(i, l, h: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
else if i > h then
result := h
else result := i;
end;
 
procedure rgb_to_hsl(r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
{$IFNDEF VER4UP}
function Max(a, b: Double): Double;
begin
Result := a; if b > a then Result := b;
end;
function Min(a, b: Double): Double;
begin
Result := a; if b < a then Result := b;
end;
{$ENDIF}
var
v, m, vm: Double;
r2, g2, b2: Double;
begin
h := 0;
s := 0;
l := 0;
v := Max(r, g);
v := Max(v, b);
m := Min(r, g);
m := Min(m, b);
l := (m + v) / 2.0;
if l <= 0.0 then
exit;
vm := v - m;
s := vm;
if s > 0.0 then
begin
if l <= 0.5 then
s := s / (v + m)
else s := s / (2.0 - v - m);
end
else exit;
r2 := (v - 4) / vm;
g2 := (v - g) / vm;
b2 := (v - b) / vm;
if r = v then
begin
if g = m then
h := b2 + 5.0
else h := 1.0 - g2;
end
else if g = v then
begin
if b = m then
h := 1.0 + r2
else h := 3.0 - b2;
end
else
begin
if r = m then
h := 3.0 + g2
else h := 5.0 - r2;
end;
h := h / 6;
end;
 
procedure hsl_to_rgb(h, sl, l: Double; var r, g, b: Double); {$IFDEF VER9UP}inline;{$ENDIF}
var
v: Double;
m, sv: Double;
sextant: Integer;
fract, vsf, mid1, mid2: Double;
begin
if l <= 0.5 then
v := l * (1.0 + sl)
else v := l + sl - l * sl;
if v <= 0 then
begin
r := 0.0;
g := 0.0;
b := 0.0;
end
else
begin
m := l + l - v;
sv := (v - m) / v;
h := h * 6.0;
sextant := Trunc(h);
fract := h - sextant;
vsf := v * sv * fract;
mid1 := m + vsf;
mid2 := v - vsf;
case sextant of
0:
begin
r := v; g := mid1; b := m;
end;
1:
begin
r := mid2; g := v; b := m;
end;
2:
begin
r := m; g := v; b := mid1;
end;
3:
begin
r := m; g := mid2; b := v;
end;
4:
begin
r := mid1; g := m; b := v;
end;
5:
begin
r := v; g := m; b := mid2;
end;
end;
end;
end;
 
var
src_row, dest_row: PByte;
src, dest: PByteArray;
color, colors: array[0..3] of Integer;
SpokeColor: PIntegerArray;
spoke: PDoubleArray;
x1, y1, x2, y2, row, col, x, y, alpha, has_alpha, bpp, progress, max_progress, xc, yc, i, j: Integer;
u, v, l, l0, w, w1, c, nova_alpha, src_alpha, new_alpha, compl_ratio, ratio, r, g, b, h, s, lu, SpokeCol: Double;
dstDIB: TDIB;
begin
colors[0] := sr;
colors[1] := sg;
colors[2] := sb;
new_alpha := 0;
 
GetMem(spoke, NSpokes * sizeof(Double));
GetMem(spokecolor, NSpokes * sizeof(Integer) * 3);
dstDIB := TDIB.Create;
dstDIB.Assign(Self);
dstDIB.Canvas.Brush.Color := clBlack;
dstDIB.Canvas.FillRect(dstDIB.Canvas.ClipRect);
try
rgb_to_hsl(colors[0] / 255.0, colors[1] / 255.0, colors[2] / 255.0, h, s, lu);
 
for i := 0 to NSpokes - 1 do
begin
spoke[i] := gauss;
h := h + randomhue / 360.0 * ({Random(RAND_MAX)}RandomSpok / RAND_MAX - 0.5);
if h < 0 then
h := h + 1.0
else if h > 1.0 then
h := h - 1.0;
hsl_to_rgb(h, s, lu, r, g, b);
spokecolor[3 * i + 0] := Trunc(255 * r);
spokecolor[3 * i + 1] := Trunc(255 * g);
spokecolor[3 * i + 2] := Trunc(255 * b);
end;
 
xc := cx;
yc := cy;
l0 := (x2 - xc) / 4 + 1;
bpp := Self.BitCount div 8;
has_alpha := 0;
alpha := bpp;
y := 0;
for row := 0 to Self.Height - 1 do begin
src_row := Self.ScanLine[row];
dest_row := dstDIB.ScanLine[row];
src := Pointer(src_row);
dest := Pointer(dest_row);
x := 0;
for col := 0 to Self.Width - 1 do begin
u := (x - xc) / radius;
v := (y - yc) / radius;
l := sqrt((u * u) + (v * v));
c := (arctan2(u, v) / (2 * M_PI) + 0.51) * NSpokes;
i := floor(c);
c := c - i;
i := i mod NSpokes;
w1 := spoke[i] * (1 - c) + spoke[(i + 1) mod NSpokes] * c;
w1 := w1 * w1;
w := 1 / (l + 0.001) * 0.9;
nova_alpha := Clamp(w, 0.0, 1.0);
ratio := nova_alpha;
compl_ratio := 1.0 - ratio;
for j := 0 to alpha - 1 do
begin
spokecol := spokecolor[3 * i + j] * (1.0 - c) + spokecolor[3 * ((i + 1) mod nspokes) + j] * c;
if w > 1.0 then
color[j] := IClamp(Trunc(spokecol * w), 0, 255)
else
color[j] := Trunc(src[j] * compl_ratio + spokecol * ratio);
color[j] := Trunc(color[j] + 255 * Clamp(w1 * w, 0.0, 1.0));
dest[j] := IClamp(color[j], 0, 255);
end;
inc(Integer(src), bpp);
inc(Integer(dest), bpp);
inc(x);
end;
inc(y);
end;
finally
Self.Assign(dstDIB);
dstDIB.Free;
FreeMem(Spoke);
FreeMem(SpokeColor);
end;
end;
 
procedure TDIB.DrawMandelbrot(ao, au: Integer; bo, bu: Double);
var
c1, c2, z1, z2, tmp: Double;
i, j, Count: Integer;
dstDIB: TDIB;
X, Y: Double;
X2, Y2: Integer;
begin
dstDIB := TDIB.Create;
dstDIB.Assign(Self);
X2 := dstDIB.FWidth;
Y2 := dstDIB.FHeight;
{as Example
ao := 1;
au := -2;
bo := 1.5;
bu := -1.5;
}
X := (ao - au) / dstDIB.FWidth;
Y := (bo - bu) / dstDIB.FHeight;
try
c2 := bu;
for i := 10 to X2 do
begin
c1 := au;
for j := 0 to Y2 do
begin
z1 := 0;
z2 := 0;
Count := 0;
{count is deep of iteration of the mandelbrot set
if |z| >=2 then z is not a member of a mandelset}
while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
begin
tmp := z1;
z1 := z1 * z1 - z2 * z2 + c1;
z2 := 2 * tmp * z2 + c2;
Inc(Count);
end;
//the color-palette depends on TColor(n*count mod t)
dstDIB.Canvas.Pixels[j, i] := (16 * Count mod 255);
c1 := c1 + X;
end;
c2 := c2 + Y;
end;
finally
Self.Assign(dstDIB);
dstDIB.Free;
end;
end;
 
procedure TDIB.SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
{Note: when depth parameter set to 0 will produce black and white picture only}
var
color, color2: longint;
r, g, b, rr, gg: byte;
h, w: Integer;
p0: pbytearray;
x, y: Integer;
begin
if Self.BitCount = 24 then
begin
Self.DoGrayScale;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rr := r + (depth * 2);
gg := g + depth;
if rr <= ((depth * 2) - 1) then
rr := 255;
if gg <= (depth - 1) then
gg := 255;
p0[x * 3] := rr;
p0[x * 3 + 1] := gg;
p0[x * 3 + 2] := b;
end;
end;
Exit
end;
{this alogorithm is slower because does not use scanline property}
for h := 0 to Self.Height-1 do
begin
for w := 0 to Self.Width-1 do
begin
//first convert the bitmap to greyscale
color := ColorToRGB(Self.Canvas.Pixels[w, h]);
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
color2 := (r + g + b) div 3;
Self.Canvas.Pixels[w, h] := RGB(color2, color2, color2);
//then convert it to sepia
color := ColorToRGB(Self.Canvas.Pixels[w, h]);
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
rr := r + (depth * 2);
gg := g + depth;
if rr <= ((depth * 2) - 1) then
rr := 255;
if gg <= (depth - 1) then
gg := 255;
Self.Canvas.Pixels[w, h] := RGB(rr, gg, b);
end;
end;
 
end;
 
procedure TDIB.EncryptDecrypt(const Key: Integer);
{for decript call it again}
var
BytesPorScan: Integer;
w, h: Integer;
p: pByteArray;
begin
try
BytesPorScan := Abs(Integer(Self.ScanLine[1]) -
Integer(Self.ScanLine[0]));
except
raise Exception.Create('Error ');
end;
RandSeed := Key;
for h := 0 to Self.Height - 1 do
begin
P := Self.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
P^[w] := P^[w] xor Random(256);
end;
end;
 
procedure TDIB.LinePolar(x, y: Integer; AngleInDegree, Length: extended; Color: cardinal);
var
xp, yp: Integer;
begin
xp := Round(Sin(AngleInDegree * Pi / 180) * Length) + x;
yp := Round(Cos(AngleInDegree * Pi / 180) * Length) + y;
AntialiasedLine(x, y, xp, yp, Color);
end;
 
//y = 0.299*g + 0.587*b + 0.114*r;
 
procedure TDIB.BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: byte);
var
cR, cG, cB: byte;
aR, aG, aB: byte;
dColor: Cardinal;
begin
aR := GetRValue(aColor);
aG := GetGValue(aColor);
aB := GetBValue(aColor);
dColor := Self.Canvas.Pixels[x, y];
cR := GetRValue(dColor);
cG := GetGValue(dColor);
cB := GetBValue(dColor);
Canvas.Pixels[x, y] := RGB((Alpha * (aR - cR) shr 8) + cR, // R alpha
(Alpha * (aG - cG) shr 8) + cG, // G alpha
(Alpha * (aB - cB) shr 8) + cB); // B alpha
end;
 
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP} overload; {$ENDIF}
begin
DIB := TDIB.Create;
DIB.SetSize(iWidth, iHeight, iBitCount);
DIB.Fill(iFillColor);
end;
 
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDib2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP} overload; {$ENDIF}
begin
DIB := TDIB.Create;
if Assigned(iBitmap) then
DIB.CreateDIBFromBitmap(iBitmap)
else
DIB.Fill(clBlack);
end;
 
initialization
TPicture.RegisterClipBoardFormat(CF_DIB, TDIB);
TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB);
/VCL_DELPHIX_D6/DXInptEdit.dfm
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
/VCL_DELPHIX_D6/DXClass.pas
5,15 → 5,7
{$INCLUDE DelphiXcfg.inc}
 
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, Graphics, {$IFDEF _DMO_}MultiMon,{$ENDIF}
{$IfDef StandardDX}
{$IfDef DX9}
Direct3D, DirectInput,
{$EndIf}
DirectDraw, DirectSound;
{$Else}
DirectX;
{$EndIf}
Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, DirectX;
 
type
 
58,46 → 50,6
property Drivers[Index: Integer]: TDirectXDriver read GetDriver; default;
end;
 
{$IFDEF _DMO_}
{ TDirectXDriverEx }
 
TDirectXDriverEx = class(TCollectionItem)
private
FGUID: PGUID;
FGUID2: TGUID;
FDescription: string;
FDriverName: string;
FMonitor: HMonitor;
FMonitorInfo: TMonitorInfo;
procedure SetGUID(Value: PGUID);
function ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;
function GetMonitorInfo: TMonitorInfo;
function GetFlags: DWORD;
function GetTempSpace: TRect;
function GetWorkSpace: TRect;
public
property GUID: PGUID read FGUID write SetGUID;
property Monitor: HMonitor read FMonitor write FMonitor;
property MonitorInfo: TMonitorInfo read GetMonitorInfo;
published
property Description: string read FDescription write FDescription;
property DriverName: string read FDriverName write FDriverName;
property WorkSpace: TRect read GetWorkSpace;
property TempSpace: TRect read GetTempSpace;
property Flags: DWORD read GetFlags;
end;
 
{ TDirectXDriversEx }
 
TDirectXDriversEx = class(TCollection)
private
function GetDriver(Index: Integer): TDirectXDriverEx;
public
constructor Create;
property Drivers[Index: Integer]: TDirectXDriverEx read GetDriver; default;
end;
{$ENDIF}
{ TDXForm }
 
TDXForm = class(TForm)
218,137 → 170,20
function IndexOf(const Name: string): Integer;
end;
 
{Addapted from RXLib.PicClip}
function Max(Val1, Val2: Integer): Integer;
function Min(Val1, Val2: Integer): Integer;
 
{ TPicClip }
TCellRange = 1..MaxInt;
 
TDXPictureClip = class(TComponent)
private
FPicture: TPicture;
FRows: TCellRange;
FCols: TCellRange;
FBitmap: TBitmap;
FMasked: Boolean;
FMaskColor: TColor;
FOnChange: TNotifyEvent;
procedure CheckIndex(Index: Integer);
function GetCell(Col, Row: Cardinal): TBitmap;
function GetGraphicCell(Index: Integer): TBitmap;
function GetDefaultMaskColor: TColor;
function GetIsEmpty: Boolean;
function GetCount: Integer;
function GetHeight: Integer;
function GetWidth: Integer;
function IsMaskStored: Boolean;
procedure PictureChanged(Sender: TObject);
procedure SetHeight(Value: Integer);
procedure SetPicture(Value: TPicture);
procedure SetWidth(Value: Integer);
procedure SetMaskColor(Value: TColor);
protected
procedure AssignTo(Dest: TPersistent); override;
procedure Changed; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function GetIndex(Col, Row: Cardinal): Integer;
procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);
procedure DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
property Cells[Col, Row: Cardinal]: TBitmap read GetCell;
property GraphicCell[Index: Integer]: TBitmap read GetGraphicCell;
property IsEmpty: Boolean read GetIsEmpty;
property Count: Integer read GetCount;
published
property Cols: TCellRange read FCols write FCols default 1;
property Height: Integer read GetHeight write SetHeight stored False;
property Masked: Boolean read FMasked write FMasked default True;
property Rows: TCellRange read FRows write FRows default 1;
property Picture: TPicture read FPicture write SetPicture;
property MaskColor: TColor read FMaskColor write SetMaskColor stored IsMaskStored;
property Width: Integer read GetWidth write SetWidth stored False;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
 
function Max(Val1, Val2: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function Min(Val1, Val2: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
 
function Cos256(i: Integer): Double;
function Sin256(i: Integer): Double;
 
function PointInRect(const Point: TPoint; const Rect: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function RectInRect(const Rect1, Rect2: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function OverlapRect(const Rect1, Rect2: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function PointInRect(const Point: TPoint; const Rect: TRect): Boolean;
function RectInRect(const Rect1, Rect2: TRect): Boolean;
function OverlapRect(const Rect1, Rect2: TRect): Boolean;
 
function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect; {$IFDEF VER9UP}inline;{$ENDIF}
 
{ Transformations routines}
 
const
L_Curve = 0;//The left curve
R_Curve = 1;//The right curve
 
C_Add = 0;//Increase (BTC)
C_Dec = 1;//Decrease (ETC)
 
Type
TDblPoint = packed record
X, Y: Double;
end;
TSngPoint = packed record //SinglePoint
X, Y: Single;
end;
 
 
//Transformation matrix
T2DRowCol = Array[1..3] of Array[1..3] of Double;
T2DVector = Array[1..3] of Double;
//Distance between 2 points
function Get2PointRange(a,b: TDblPoint):Double;
//From vector angular calculation
function Get256(dX,dY: Double):Double;
//The angular calculation of the A from B
function GetARadFromB(A,B: TDblPoint):Double;
 
//It calculates the TDblPoint
function DblPoint(a,b:Double):TDblPoint;
//It converts the TDboPoint to the TPoint
function TruncDblPoint(DblPos: TDblPoint): TPoint;
 
function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;
 
function Ini2DRowCol: T2DRowCol;
function Trans2DRowCol(x,y:double):T2DRowCol;
function Scale2DRowCol(x,y:double):T2DRowCol;
function Rotate2DRowCol(Theta:double):T2DRowCol;
function RotateIntoX2DRowCol(x,y: double):T2DRowCol;
function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;
function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;
function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;
function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;
function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;
 
//Collision decision
function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;
function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;
function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;
 
//If A is closer than B from starting point S, the True is returned.
function CheckNearAThanB(S,A,B: TDblPoint): Boolean;
 
//The Angle of 256 period is returned
function Angle256(Angle: Single): Single;
 
{ Support functions }
 
function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect;
procedure ReleaseCom(out Com);
function DXLoadLibrary(const FileName, FuncName: string): TFarProc;
 
{ Simple helper }
 
procedure Log(const Co: string; const FName: string{$IFDEF VER4UP} = 'c:\logerr.txt'{$ENDIF});
 
implementation
 
uses DXConsts;
855,763 → 690,8
Result := -1;
end;
 
{ TDXPictureClip }
 
constructor TDXPictureClip.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
FBitmap := TBitmap.Create;
FRows := 1;
FCols := 1;
FMaskColor := GetDefaultMaskColor;
FMasked := True;
end;
 
destructor TDXPictureClip.Destroy;
begin
FOnChange := nil;
FPicture.OnChange := nil;
FBitmap.Free;
FPicture.Free;
inherited Destroy;
end;
 
procedure TDXPictureClip.Assign(Source: TPersistent);
begin
if Source is TDXPictureClip then begin
with TDXPictureClip(Source) do begin
Self.FRows := Rows;
Self.FCols := Cols;
Self.FMasked := Masked;
Self.FMaskColor := MaskColor;
Self.FPicture.Assign(FPicture);
end;
end
else if (Source is TPicture) or (Source is TGraphic) then
FPicture.Assign(Source)
else inherited Assign(Source);
end;
 
type
THack = class(TImageList);
 
procedure TDXPictureClip.AssignTo(Dest: TPersistent);
var
I: Integer;
SaveChange: TNotifyEvent;
begin
if (Dest is TPicture) then Dest.Assign(FPicture)
else if (Dest is TImageList) and not IsEmpty then begin
with TImageList(Dest) do begin
SaveChange := OnChange;
try
OnChange := nil;
Clear;
Width := Self.Width;
Height := Self.Height;
for I := 0 to Self.Count - 1 do begin
if Self.Masked and (MaskColor <> clNone) then
TImageList(Dest).AddMasked(GraphicCell[I], MaskColor)
else TImageList(Dest).Add(GraphicCell[I], nil);
end;
Masked := Self.Masked;
finally
OnChange := SaveChange;
end;
THack(Dest).Change;
end;
end
else inherited AssignTo(Dest);
end;
 
procedure TDXPictureClip.Changed;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
 
function TDXPictureClip.GetIsEmpty: Boolean;
begin
Result := not Assigned(Picture) or Picture.Graphic.Empty;
end;
 
function TDXPictureClip.GetCount: Integer;
begin
if IsEmpty then Result := 0
else Result := Cols * Rows;
end;
const
{ TBitmap.GetTransparentColor from GRAPHICS.PAS uses this value }
PaletteMask = $02000000;
 
procedure TDXPictureClip.Draw(Canvas: TCanvas; X, Y, Index: Integer);
 
function PaletteColor(Color: TColor): Longint;
begin
Result := ColorToRGB(Color) or PaletteMask;
end;
procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;
TransparentColor: TColorRef);
var
Color: TColorRef;
bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
MemDC, BackDC, ObjectDC, SaveDC: HDC;
palDst, palMem, palSave, palObj: HPalette;
begin
{ Create some DCs to hold temporary data }
BackDC := CreateCompatibleDC(DstDC);
ObjectDC := CreateCompatibleDC(DstDC);
MemDC := CreateCompatibleDC(DstDC);
SaveDC := CreateCompatibleDC(DstDC);
{ Create a bitmap for each DC }
bmAndObject := CreateBitmap(SrcW, SrcH, 1, 1, nil);
bmAndBack := CreateBitmap(SrcW, SrcH, 1, 1, nil);
bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);
bmSave := CreateCompatibleBitmap(DstDC, SrcW, SrcH);
{ Each DC must select a bitmap object to store pixel data }
bmBackOld := SelectObject(BackDC, bmAndBack);
bmObjectOld := SelectObject(ObjectDC, bmAndObject);
bmMemOld := SelectObject(MemDC, bmAndMem);
bmSaveOld := SelectObject(SaveDC, bmSave);
{ Select palette }
palDst := 0; palMem := 0; palSave := 0; palObj := 0;
if Palette <> 0 then begin
palDst := SelectPalette(DstDC, Palette, True);
RealizePalette(DstDC);
palSave := SelectPalette(SaveDC, Palette, False);
RealizePalette(SaveDC);
palObj := SelectPalette(ObjectDC, Palette, False);
RealizePalette(ObjectDC);
palMem := SelectPalette(MemDC, Palette, True);
RealizePalette(MemDC);
end;
{ Set proper mapping mode }
SetMapMode(SrcDC, GetMapMode(DstDC));
SetMapMode(SaveDC, GetMapMode(DstDC));
{ Save the bitmap sent here }
BitBlt(SaveDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SRCCOPY);
{ Set the background color of the source DC to the color, }
{ contained in the parts of the bitmap that should be transparent }
Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));
{ Create the object mask for the bitmap by performing a BitBlt() }
{ from the source bitmap to a monochrome bitmap }
BitBlt(ObjectDC, 0, 0, SrcW, SrcH, SaveDC, 0, 0, SRCCOPY);
{ Set the background color of the source DC back to the original }
SetBkColor(SaveDC, Color);
{ Create the inverse of the object mask }
BitBlt(BackDC, 0, 0, SrcW, SrcH, ObjectDC, 0, 0, NOTSRCCOPY);
{ Copy the background of the main DC to the destination }
BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);
{ Mask out the places where the bitmap will be placed }
StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, SrcH, SRCAND);
{ Mask out the transparent colored pixels on the bitmap }
BitBlt(SaveDC, 0, 0, SrcW, SrcH, BackDC, 0, 0, SRCAND);
{ XOR the bitmap with the background on the destination DC }
StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, SrcH, SRCPAINT);
{ Copy the destination to the screen }
BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,
SRCCOPY);
{ Restore palette }
if Palette <> 0 then begin
SelectPalette(MemDC, palMem, False);
SelectPalette(ObjectDC, palObj, False);
SelectPalette(SaveDC, palSave, False);
SelectPalette(DstDC, palDst, True);
end;
{ Delete the memory bitmaps }
DeleteObject(SelectObject(BackDC, bmBackOld));
DeleteObject(SelectObject(ObjectDC, bmObjectOld));
DeleteObject(SelectObject(MemDC, bmMemOld));
DeleteObject(SelectObject(SaveDC, bmSaveOld));
{ Delete the memory DCs }
DeleteDC(MemDC);
DeleteDC(BackDC);
DeleteDC(ObjectDC);
DeleteDC(SaveDC);
end;
procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;
TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,
SrcW, SrcH: Integer);
var
CanvasChanging: TNotifyEvent;
begin
if DstW <= 0 then DstW := Bitmap.Width;
if DstH <= 0 then DstH := Bitmap.Height;
if (SrcW <= 0) or (SrcH <= 0) then begin
SrcX := 0; SrcY := 0;
SrcW := Bitmap.Width;
SrcH := Bitmap.Height;
end;
if not Bitmap.Monochrome then
SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);
CanvasChanging := Bitmap.Canvas.OnChanging;
Bitmap.Canvas.Lock;
try
Bitmap.Canvas.OnChanging := nil;
if TransparentColor = clNone then begin
StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,
SrcX, SrcY, SrcW, SrcH, Dest.CopyMode);
end
else begin
if TransparentColor = clDefault then
TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];
if Bitmap.Monochrome then TransparentColor := clWhite
else TransparentColor := ColorToRGB(TransparentColor);
StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,
Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, SrcH, Bitmap.Palette,
TransparentColor);
end;
finally
Bitmap.Canvas.OnChanging := CanvasChanging;
Bitmap.Canvas.Unlock;
end;
end;
procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
Bitmap: TBitmap; TransparentColor: TColor);
begin
StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,
Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);
end;
var
Image: TGraphic;
begin
if Index < 0 then Image := Picture.Graphic
else Image := GraphicCell[Index];
if (Image <> nil) and not Image.Empty then begin
if FMasked and (FMaskColor <> clNone) and
(Picture.Graphic is TBitmap) then
DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image), FMaskColor)
else Canvas.Draw(X, Y, Image);
end;
end;
 
procedure TDXPictureClip.DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
var
X, Y: Integer;
begin
X := (Rect.Left + Rect.Right - Width) div 2;
Y := (Rect.Bottom + Rect.Top - Height) div 2;
Draw(Canvas, X, Y, Index);
end;
 
procedure TDXPictureClip.CheckIndex(Index: Integer);
begin
if (Index >= Cols * Rows) or (Index < 0) then
raise EListError.CreateFmt('%s (%d)', ['Load list error', Index]);
end;
 
function TDXPictureClip.GetIndex(Col, Row: Cardinal): Integer;
begin
Result := Col + (Row * Cols);
if (Result >= Cols * Rows) or IsEmpty then Result := -1;
end;
 
function TDXPictureClip.GetCell(Col, Row: Cardinal): TBitmap;
begin
Result := GetGraphicCell(GetIndex(Col, Row));
end;
 
function TDXPictureClip.GetGraphicCell(Index: Integer): TBitmap;
procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,
Index: Integer);
var
CellWidth, CellHeight: Integer;
begin
if (Source <> nil) and (Dest <> nil) then begin
if Cols <= 0 then Cols := 1;
if Rows <= 0 then Rows := 1;
if Index < 0 then Index := 0;
CellWidth := Source.Width div Cols;
CellHeight := Source.Height div Rows;
with Dest do begin
Width := CellWidth; Height := CellHeight;
end;
if Source is TBitmap then begin
Dest.Canvas.CopyRect(Bounds(0, 0, CellWidth, CellHeight),
TBitmap(Source).Canvas, Bounds((Index mod Cols) * CellWidth,
(Index div Cols) * CellHeight, CellWidth, CellHeight));
Dest.TransparentColor := TBitmap(Source).TransparentColor;
end
else begin
Dest.Canvas.Brush.Color := clSilver;
Dest.Canvas.FillRect(Bounds(0, 0, CellWidth, CellHeight));
Dest.Canvas.Draw(-(Index mod Cols) * CellWidth,
-(Index div Cols) * CellHeight, Source);
end;
Dest.Transparent := Source.Transparent;
end;
end;
begin
CheckIndex(Index);
AssignBitmapCell(Picture.Graphic, FBitmap, Cols, Rows, Index);
if Picture.Graphic is TBitmap then
if FBitmap.PixelFormat <> pfDevice then
FBitmap.PixelFormat := TBitmap(Picture.Graphic).PixelFormat;
FBitmap.TransparentColor := FMaskColor or PaletteMask;
FBitmap.Transparent := (FMaskColor <> clNone) and Masked;
Result := FBitmap;
end;
 
function TDXPictureClip.GetDefaultMaskColor: TColor;
begin
Result := clOlive;
if (Picture.Graphic <> nil) and (Picture.Graphic is TBitmap) then
Result := TBitmap(Picture.Graphic).TransparentColor and
not PaletteMask;
end;
 
function TDXPictureClip.GetHeight: Integer;
begin
Result := Picture.Height div FRows;
end;
 
function TDXPictureClip.GetWidth: Integer;
begin
Result := Picture.Width div FCols;
end;
 
function TDXPictureClip.IsMaskStored: Boolean;
begin
Result := MaskColor <> GetDefaultMaskColor;
end;
 
procedure TDXPictureClip.SetMaskColor(Value: TColor);
begin
if Value <> FMaskColor then begin
FMaskColor := Value;
Changed;
end;
end;
 
procedure TDXPictureClip.PictureChanged(Sender: TObject);
begin
FMaskColor := GetDefaultMaskColor;
if not (csReading in ComponentState) then Changed;
end;
 
procedure TDXPictureClip.SetHeight(Value: Integer);
begin
if (Value > 0) and (Picture.Height div Value > 0) then
Rows := Picture.Height div Value;
end;
 
procedure TDXPictureClip.SetWidth(Value: Integer);
begin
if (Value > 0) and (Picture.Width div Value > 0) then
Cols := Picture.Width div Value;
end;
 
procedure TDXPictureClip.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
 
{ Transformations routines }
{ Authorisation: Mr. Takanori Kawasaki}
 
//Distance between 2 points is calculated
function Get2PointRange(a,b: TDblPoint):Double;
var
x,y: Double;
begin
x := a.X - b.X;
y := a.Y - b.Y;
Result := Sqrt(x*x+y*y);
end;
 
//Direction angle in the coordinate A which was seen from coordinate B is calculated
function GetARadFromB(A,B: TDblPoint):Double;
var
dX,dY: Double;
begin
dX := A.X - B.X;
dY := A.Y - B.Y;
Result := Get256(dX,dY);
end;
 
//Direction angle is returned with 0 - 255.
function Get256(dX,dY:Double):Double;
begin
Result := 0;
if dX > 0 then
begin//0-63
if dY > 0 then Result := ArcTan(dY / dX) // 0 < Res < 90
else//0
if dY = 0 then Result := 0 // 0
else//192-255
if dY < 0 then Result := 2*Pi + ArcTan(dY / dX) // 270 < Res < 360
end else
if dX = 0 then
begin//64
if dY > 0 then Result := 1 / 2 * Pi // 90
else//0
if dY = 0 then Result := 0 // 0
else//192
if dY < 0 then Result := 3 / 2 * Pi // 270
end else
if dX < 0 then
begin//64-127
if dY > 0 then Result := Pi + ArcTan(dY / dX) // 90 < Res < 180
else//128
if dY = 0 then Result := Pi // 180
else//128-191
if dY < 0 then Result := Pi + ArcTan(dY / dX) // 180 < Res < 270
end;
Result := 256 * Result / (2*Pi);
end;
 
//From the coordinate SP the Range it calculates the point which leaves with the angular Angle
function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;
begin
Result.X := SP.X + Range * Cos(Angle);
Result.Y := SP.Y + Range * Sin(Angle);
end;
 
//* As for coordinate transformation coordinate for mathematics is used
//Identity matrix for the 2d is returned.
function Ini2DRowCol: T2DRowCol;
var
i,ii:integer;
begin
for i := 1 to 3 do
for ii := 1 to 3 do
if i = ii then Result[i,ii] := 1 else Result[i,ii] := 0;
end;
 
//Transformation matrix of the portable quantity
//where the one for 2d is appointed is returned.
function Trans2DRowCol(x,y:double):T2DRowCol;
begin
Result := Ini2DRowCol;
Result[3,1] := x;
Result[3,2] := y;
end;
 
//Conversion coordinate of the expansion and contraction
//quantity where the one for 2d is appointed is returned.
function Scale2DRowCol(x,y:double):T2DRowCol;
begin
Result := Ini2DRowCol;
Result[1,1] := x;
Result[2,2] := y;
end;
 
//Coordinate transformation of the rotary quantity
//where the one for 2d is appointed is returned.
function Rotate2DRowCol(Theta:double):T2DRowCol;
begin
Result := Ini2DRowCol;
Result[1,1] := Cos256(Trunc(Theta));
Result[1,2] := Sin256(Trunc(Theta));
Result[2,1] := -1 * Result[1,2];
Result[2,2] := Result[1,1];
end;
 
//You apply two conversion coordinates and adjust.
function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;
begin
Result[1,1] := A[1,1] * B[1,1] + A[1,2] * B[2,1];
Result[1,2] := A[1,1] * B[1,2] + A[1,2] * B[2,2];
Result[1,3] := 0;
Result[2,1] := A[2,1] * B[1,1] + A[2,2] * B[2,1];
Result[2,2] := A[2,1] * B[1,2] + A[2,2] * B[2,2];
Result[2,3] := 0;
Result[3,1] := A[3,1] * B[1,1] + A[3,2] * B[2,1] + B[3,1];
Result[3,2] := A[3,1] * B[1,2] + A[3,2] * B[2,2] + B[3,2];
Result[3,3] := 1;
end;
 
//Until coordinate (the X and the Y) comes on the X axis,
//the conversion coordinate which turns the position
//of the point is returned.
function RotateIntoX2DRowCol(x,y: double):T2DRowCol;
var
d: double;
begin
Result := Ini2DRowCol;
d := sqrt(x*x+y*y);
Result[1,1] := x / d;
Result[1,2] := y / d;
Result[2,1] := -1 * Result[1,2];
Result[2,2] := Result[1,1];
end;
 
//Coordinate (the X and the Y) as a center, the conversion
//coordinate which does the scaling of the magnification ratio
//which is appointed with the Sx and the Sy is returned.
function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;
var
T,S,TInv,M:T2DRowCol;
begin
T := Trans2DRowCol(-x,-y);
TInv := Trans2DRowCol(x,y);
S := Scale2DRowCol(Sx,Sy);
M := Multiply2DRowCol(T,S);
Result := Multiply2DRowCol(M,T);
end;
 
//Coordinate (the X and the Y) it passes, comes hard and
//(DX and the dy) with the direction which is shown it
//returns the transformation matrix which does the reflected
//image conversion which centers the line which faces.
function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;
var
T,R,S,RInv,TInv,M1,M2,M3: T2DRowCol;
begin
T := Trans2DRowCol(-x,-y);
TInv := Trans2DRowCol(x,y);
R := RotateIntoX2DRowCol(dx,dy);
RInv := RotateIntoX2DRowCol(dx,-dy);
S := Scale2DRowCol(1,-1);
M1 := Multiply2DRowCol(T,R);
M2 := Multiply2DRowCol(S,RInv);
M3 := Multiply2DRowCol(M1,M2);
Result := Multiply2DRowCol(M3,TInv);
end;
 
//Coordinate focusing on (the X and the Y) the transformation
//matrix which turns the position of the point with angle Theta is returned.
function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;
var
T,R,TInv,M: T2DRowCol;
begin
T := Trans2DRowCol(-x,-y);
TInv := Trans2DRowCol(x,y);
R := Rotate2DRowCol(Theta);
M := Multiply2DRowCol(T,R);
Result := Multiply2DRowCol(M,TInv);
end;
 
//Transformation matrix is applied to the point.
function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;
begin
Result[1] := V[1] * M[1,1] + V[2] * M[2,1] + M[3,1];
Result[2] := V[1] * M[1,2] + V[2] * M[2,2] + M[3,2];
Result[3] := 1;
end;
 
//The TDblPoint is returned
function DblPoint(a,b:Double):TDblPoint;
begin
Result.X := a;
Result.Y := b;
end;
 
function TruncDblPoint(DblPos: TDblPoint): TPoint;
begin
Result.X := Trunc(DblPos.X);
Result.Y := Trunc(DblPos.Y);
end;
{
+-----------------------------------------------------------------------------+
|Collision decision |
+-----------------------------------------------------------------------------+}
 
//Point and circle
function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;
begin
Result := (PPos.X - CPos.X)*(PPos.X - CPos.X)+(PPos.Y - CPos.Y)*(PPos.Y - CPos.Y)<= R*R;
end;
 
//Circle and circle
function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;
begin
Result := (C1Pos.X - C2Pos.X)*(C1Pos.X - C2Pos.X)+(C1Pos.Y - C2Pos.Y)*(C1Pos.Y - C2Pos.Y) <= (R1+R2)*(R1+R2);
end;
 
//Circle and line segment
function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;
var
V,C: TPoint;
VC,VV,CC:integer;
begin
Result := False;
V.X := EPos.X - SPos.X; V.Y := EPos.Y - SPos.Y;
C.X := CPos.X - SPos.X; C.Y := CPos.Y - SPos.Y;
VC := V.X * C.X + V.Y * C.Y;
if VC < 0 then
begin
Result := (C.X * C.X + C.Y * C.Y) <= R*R;
end
else
begin
VV := V.X * V.X + V.Y * V.Y;
if VC >= VV then
begin
Result := (EPos.X - CPos.X)*(EPos.X - CPos.X)+(EPos.Y - CPos.Y)*(EPos.Y - CPos.Y) <= R * R;
end
else
if VC < VV then
begin
CC := C.X * C.X + C.Y * C.Y;
Result := CC - (VC div VV)* VC <= R*R;
end;
end;
end;
 
//Angle recalc
function Angle256(Angle: Single): Single;
begin
Result := Angle;
While Result < 0 do Result := Result + 256;
While Result >= 256 do Result := Result -256;
end;
 
//If A is closer than B from starting point S, the True is returned.
function CheckNearAThanB(S,A,B: TDblPoint): Boolean;
begin
Result := (S.X-A.X)*(S.X-A.X)+(S.Y-A.Y)*(S.Y-A.Y) <= (S.X-B.X)*(S.X-B.X)+(S.Y-B.Y)*(S.Y-B.Y);
end;
 
function CircumCenter3Pt(const x1, y1, x2, y2, x3, y3: Single; out Px, Py: Single): Boolean;
var
A,B,C,D,E,F,G: Single;
begin
A := x2 - x1;
B := y2 - y1;
C := x3 - x1;
D := y3 - y1;
E := A * (x1 + x2) + B * (y1 + y2);
F := C * (x1 + x3) + D * (y1 + y3);
G := 2.0 * (A * (y3 - y2) - B * (x3 - x2));
Result := G <> 0.0;
if Result then begin
Px := (D * E - B * F) / G;
Py := (A * F - C * E) / G;
end;
end;
 
function Distance(const x1, y1, x2, y2: Double): Double;
begin
Result := Sqrt(Sqr(y2 - y1) + Sqr(x2 - x1));
end;
 
procedure InCenter(const x1, y1, x2, y2, x3, y3: Double; out Px, Py: Double);
var
Perim: Double;
Side12: Double;
Side23: Double;
Side31: Double;
begin
Side12 := Distance(x1, y1, x2, y2);
Side23 := Distance(x2, y2, x3, y3);
Side31 := Distance(x3, y3, x1, y1);
{ Using Heron's S=UR }
Perim := 1.0 / (Side12 + Side23 + Side31);
Px := (Side23 * x1 + Side31 * x2 + Side12 * x3) * Perim;
Py := (Side23 * y1 + Side31 * y2 + Side12 * y3) * Perim;
end;
 
function PointInTriangle(const Px, Py, x1, y1, x2, y2, x3, y3: Double): Boolean;
function Orientation(const x1, y1, x2, y2, Px, Py: Double): Integer;
var
Orin: Double;
begin
(* Linear determinant of the 3 points *)
Orin := (x2 - x1) * (py - y1) - (px - x1) * (y2 - y1);
 
if Orin > 0.0 then
Result := +1 (* Orientaion is to the right-hand side *)
else if Orin < 0.0 then
Result := -1 (* Orientaion is to the left-hand side *)
else
Result := 0; (* Orientaion is neutral aka collinear *)
end;
var
Or1, Or2, Or3: Integer;
begin
Or1 := Orientation(x1, y1, x2, y2, Px, Py);
Or2 := Orientation(x2, y2, x3, y3, Px, Py);
Or3 := Orientation(x3, y3, x1, y1, Px, Py);
 
if (Or1 = Or2) and (Or2 = Or3) then
Result := True
else if Or1 = 0 then
Result := (Or2 = 0) or (Or3 = 0)
else if Or2 = 0 then
Result := (Or1 = 0) or (Or3 = 0)
else if Or3 = 0 then
Result := (Or2 = 0) or (Or1 = 0)
else
Result := False;
end;
 
procedure Log(const Co: string; const FName: string);
var F: Text; D: TDateTime;
Hour, Minute, Second, MSec: Word;
begin
AsSignFile(F, FName);
if FileExists(FName) then Append(F)
else ReWrite(F);
try
D := Now;
DecodeTime(D, Hour, Minute, Second, MSec);
WriteLn(F, DateToStr(D) + ' ' + IntToStr(Hour)+':'+IntToStr(Minute)+':'+IntToStr(Second)+ '.'+IntToStr(MSec) +' ' + Co);
finally
CloseFile(F);
end;
end;
 
{$IFDEF _DMO_}
 
{ TDirectXDriverEx }
 
function TDirectXDriverEx.ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;
begin
ZeroMemory(@Result, sizeof(Result));
Result.cbSize := SizeOf(Result);
MultiMon.GetMonitorInfo(iMonitor, @Result);
end;
 
function TDirectXDriverEx.GetFlags: DWORD;
begin
Result := ConvertHMonitor(FMonitor).dwFlags;
end;
 
function TDirectXDriverEx.GetMonitorInfo: TMonitorInfo;
begin
Result:= ConvertHMonitor(FMonitor);
end;
 
function TDirectXDriverEx.GetTempSpace: TRect;
begin
Result := ConvertHMonitor(FMonitor).rcWork
end;
 
function TDirectXDriverEx.GetWorkSpace: TRect;
begin
Result := ConvertHMonitor(FMonitor).rcMonitor
end;
 
procedure TDirectXDriverEx.SetGUID(Value: PGUID);
begin
if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
begin
FGUID2 := Value^;
FGUID := @FGUID2;
end else
FGUID := Value;
end;
 
{ TDirectXDriversEx }
 
constructor TDirectXDriversEx.Create;
begin
inherited Create(TDirectXDriverEx);
end;
 
function TDirectXDriversEx.GetDriver(Index: Integer): TDirectXDriverEx;
begin
Result := (inherited Items[Index]) as TDirectXDriverEx;
end;
 
{$ENDIF}
 
initialization
InitCosinTable;
finalization
FreeLibList;
end.
end.
/VCL_DELPHIX_D6/Wave.pas
0,0 → 1,726
unit Wave;
 
interface
 
{$INCLUDE DelphiXcfg.inc}
 
uses
Windows, SysUtils, Classes, MMSystem;
 
type
 
{ EWaveError }
 
EWaveError = class(Exception);
 
{ TWave }
 
TWave = class(TPersistent)
private
FData: Pointer;
FFormat: PWaveFormatEx;
FFormatSize: Integer;
FSize: Integer;
procedure SetFormatSize(Value: Integer);
procedure SetSize(Value: Integer);
protected
procedure DefineProperties(Filer: TFiler); override;
procedure ReadData(Stream: TStream); virtual;
procedure WriteData(Stream: TStream); virtual;
public
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Clear;
procedure LoadFromFile(const FileName : string);
procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(const FileName : string);
procedure SaveToStream(Stream: TStream);
procedure SetPCMFormat(SamplesPerSec, BitsPerSample, Channels: Integer);
property Data: Pointer read FData;
property Format: PWaveFormatEx read FFormat;
property FormatSize: Integer read FFormatSize write SetFormatSize;
property Size: Integer read FSize write SetSize;
end;
 
{ TCustomDXWave }
 
TCustomDXWave = class(TComponent)
private
FWave: TWave;
procedure SetWave(Value: TWave);
public
constructor Create(AOnwer: TComponent); override;
destructor Destroy; override;
property Wave: TWave read FWave write SetWave;
end;
 
{ TDXWave }
 
TDXWave = class(TCustomDXWave)
published
property Wave;
end;
 
{ EWaveStreamError }
 
EWaveStreamError = class(Exception);
 
{ TCustomWaveStream }
 
TCustomWaveStream = class(TStream)
private
FPosition: Integer;
protected
function GetFilledSize: Integer; virtual;
function GetFormat: PWaveFormatEx; virtual; abstract;
function GetFormatSize: Integer; virtual;
function GetSize: Integer; virtual;
function ReadWave(var Buffer; Count: Integer): Integer; virtual;
procedure SetFormatSize(Value: Integer); virtual; abstract;
procedure SetSize(Value: Integer); override;
function WriteWave(const Buffer; Count: Integer): Integer; virtual;
public
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
procedure SetPCMFormat(SamplesPerSec, BitsPerSample, Channels: Integer);
property FilledSize: Integer read GetFilledSize;
property Format: PWaveFormatEx read GetFormat;
property FormatSize: Integer read GetFormatSize write SetFormatSize;
property Size: Integer read GetSize write SetSize;
end;
 
{ TCustomWaveStream2 }
 
TCustomWaveStream2 = class(TCustomWaveStream)
private
FFormat: PWaveFormatEx;
FFormatSize: Integer;
protected
function GetFormat: PWaveFormatEx; override;
function GetFormatSize: Integer; override;
procedure SetFormatSize(Value: Integer); override;
public
destructor Destroy; override;
end;
 
{ TWaveObjectStream }
 
TWaveObjectStream = class(TCustomWaveStream)
private
FWave: TWave;
protected
function GetFormat: PWaveFormatEx; override;
function GetFormatSize: Integer; override;
function GetSize: Integer; override;
function ReadWave(var Buffer; Count: Integer): Integer; override;
procedure SetFormatSize(Value: Integer); override;
procedure SetSize(Value: Integer); override;
function WriteWave(const Buffer; Count: Integer): Integer; override;
public
constructor Create(AWave: TWave);
end;
 
{ TWaveStream }
 
TWaveStream = class(TCustomWaveStream2)
private
FDataPosition: Integer;
FDataHeaderPosition: Integer;
FOpened: Boolean;
FOriPosition: Integer;
FReadMode: Boolean;
FSize: Integer;
FStream: TStream;
procedure CloseWriteMode;
procedure OpenReadMode;
procedure OpenWriteMode;
protected
function GetSize: Integer; override;
function ReadWave(var Buffer; Count: Integer): Integer; override;
function WriteWave(const Buffer; Count: Integer): Integer; override;
public
constructor Create(AStream: TStream);
destructor Destroy; override;
procedure Open(WriteMode: Boolean);
end;
 
{ TWaveFileStream }
 
TWaveFileStream = class(TWaveStream)
private
FFileStream: TFileStream;
public
constructor Create(const FileName: string; FileMode: Integer);
destructor Destroy; override;
end;
 
procedure MakePCMWaveFormatEx(var Format: TWaveFormatEx;
SamplesPerSec, BitsPerSample, Channels: Integer);
 
implementation
 
uses DXConsts;
 
procedure MakePCMWaveFormatEx(var Format: TWaveFormatEx;
SamplesPerSec, BitsPerSample, Channels: Integer);
begin
with Format do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := Channels;
nSamplesPerSec := SamplesPerSec;
wBitsPerSample := BitsPerSample;
nBlockAlign := nChannels*(wBitsPerSample div 8);
nAvgBytesPerSec := nBlockAlign*nSamplesPerSec;
cbSize := 0;
end;
end;
 
{ TWave }
 
const
WavePoolSize = 8096;
 
destructor TWave.Destroy;
begin
Clear;
inherited Destroy;
end;
 
procedure TWave.Assign(Source: TPersistent);
var
AWave: TWave;
begin
if Source=nil then
begin
Clear;
end else if Source is TWave then
begin
if Source<>Self then
begin
AWave := TWave(Source);
Size := AWave.Size;
FormatSize := AWave.FormatSize;
Move(AWave.Data^, FData^, FSize);
Move(AWave.Format^, FFormat^, FFormatSize);
end;
end else
inherited Assign(Source);
end;
 
procedure TWave.Clear;
begin
FreeMem(FData, 0); FData := nil;
FreeMem(FFormat, 0); FFormat := nil;
 
FSize := 0;
FFormatSize := 0;
end;
 
procedure TWave.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineBinaryProperty('WAVE', ReadData, WriteData, True);
end;
 
procedure TWave.LoadFromFile(const FileName : string);
var
Stream: TFileStream;
begin
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
 
procedure TWave.LoadFromStream(Stream: TStream);
var
WaveStream: TWaveStream;
begin
Clear;
 
WaveStream := TWaveStream.Create(Stream);
try
WaveStream.Open(False);
 
FormatSize := WaveStream.FormatSize;
Move(WaveStream.Format^, Format^, FormatSize);
Size := WaveStream.Size;
WaveStream.ReadBuffer(FData^, Size);
finally
WaveStream.Free;
end;
end;
 
procedure TWave.ReadData(Stream: TStream);
begin
LoadFromStream(Stream);
end;
 
procedure TWave.SaveToFile(const FileName : string);
var
Stream: TFileStream;
begin
Stream := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
 
procedure TWave.SaveToStream(Stream: TStream);
var
WaveStream: TWaveStream;
begin
if (FFormatSize<=0) or (FSize<=0) then Exit;
 
WaveStream := TWaveStream.Create(Stream);
try
WaveStream.FormatSize := FormatSize;
Move(Format^, WaveStream.Format^, FormatSize);
 
WaveStream.Open(True);
WaveStream.WriteBuffer(FData^, Size);
finally
WaveStream.Free;
end;
end;
 
procedure TWave.SetFormatSize(Value: Integer);
begin
if Value<=0 then Value := 0;
ReAllocMem(FFormat, Value);
FFormatSize := Value;
end;
 
procedure TWave.SetPCMFormat(SamplesPerSec, BitsPerSample, Channels: Integer);
begin
FormatSize := SizeOf(TWaveFormatEx);
MakePCMWaveFormatEx(Format^, SamplesPerSec, BitsPerSample, Channels);
end;
 
procedure TWave.SetSize(Value: Integer);
var
i: Integer;
begin
if Value<=0 then Value := 0;
 
i := (Value+WavePoolSize-1) div WavePoolSize;
if i<>(FSize+WavePoolSize-1) div WavePoolSize then
ReAllocMem(FData, i*WavePoolSize);
 
FSize := Value;
end;
 
procedure TWave.WriteData(Stream: TStream);
begin
SaveToStream(Stream);
end;
 
{ TCustomDXWave }
 
constructor TCustomDXWave.Create(AOnwer: TComponent);
begin
inherited Create(AOnwer);
FWave := TWave.Create;
end;
 
destructor TCustomDXWave.Destroy;
begin
FWave.Free;
inherited Destroy;
end;
 
procedure TCustomDXWave.SetWave(Value: TWave);
begin
FWave.Assign(Value);
end;
 
{ TCustomWaveStream }
 
function TCustomWaveStream.GetFilledSize: Longint;
begin
Result := -1;
end;
 
function TCustomWaveStream.GetFormatSize: Integer;
begin
Result := 0;
end;
 
function TCustomWaveStream.GetSize: Integer;
begin
Result := -1;
end;
 
function TCustomWaveStream.Read(var Buffer; Count: Longint): Longint;
begin
if GetSize<0 then
Result := ReadWave(Buffer, Count)
else
begin
if FPosition>Size then
FPosition := Size;
if FPosition+Count>Size then
Result := Size-FPosition
else
Result := Count;
 
Result := ReadWave(Buffer, Result);
end;
 
Inc(FPosition, Result);
end;
 
function TCustomWaveStream.ReadWave(var Buffer; Count: Integer): Integer;
begin
Result := 0;
end;
 
function TCustomWaveStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
case Origin of
soFromBeginning: FPosition := Offset;
soFromCurrent : FPosition := FPosition + Offset;
soFromEnd : FPosition := GetSize + Offset;
end;
if FPosition<0 then FPosition := 0;
if FPosition>GetSize then FPosition := GetSize;
 
Result := FPosition;
end;
 
procedure TCustomWaveStream.SetPCMFormat(SamplesPerSec, BitsPerSample, Channels: Integer);
begin
FormatSize := SizeOf(TWaveFormatEx);
MakePCMWaveFormatEx(Format^, SamplesPerSec, BitsPerSample, Channels);
end;
 
procedure TCustomWaveStream.SetSize(Value: Integer);
begin
end;
 
function TCustomWaveStream.Write(const Buffer; Count: Longint): Longint;
begin
if FPosition>Size then
FPosition := Size;
Result := WriteWave(Buffer, Count);
Inc(FPosition, Result);
end;
 
function TCustomWaveStream.WriteWave(const Buffer; Count: Integer): Integer;
begin
Result := 0;
end;
 
{ TCustomWaveStream2 }
 
destructor TCustomWaveStream2.Destroy;
begin
FormatSize := 0;
inherited Destroy;
end;
 
function TCustomWaveStream2.GetFormat: PWaveFormatEx;
begin
Result := FFormat;
end;
 
function TCustomWaveStream2.GetFormatSize: Integer;
begin
Result := FFormatSize;
end;
 
procedure TCustomWaveStream2.SetFormatSize(Value: Integer);
begin
ReAllocMem(FFormat, Value);
FFormatSize := Value;
end;
 
{ TWaveObjectStream }
 
constructor TWaveObjectStream.Create(AWave: TWave);
begin
inherited Create;
FWave := AWave;
 
FormatSize := FWave.FormatSize;
Move(FWave.Format^, Format^, FormatSize);
end;
 
function TWaveObjectStream.GetFormat: PWaveFormatEx;
begin
Result := FWave.Format;
end;
 
function TWaveObjectStream.GetFormatSize: Integer;
begin
Result := FWave.FormatSize;
end;
 
function TWaveObjectStream.GetSize: Integer;
begin
Result := FWave.Size;
end;
 
function TWaveObjectStream.ReadWave(var Buffer; Count: Integer): Integer;
begin
Result := Count;
Move(Pointer(Integer(FWave.Data)+Position)^, Buffer, Count);
end;
 
procedure TWaveObjectStream.SetFormatSize(Value: Integer);
begin
FWave.FormatSize := Value;
end;
 
procedure TWaveObjectStream.SetSize(Value: Integer);
begin
FWave.Size := Value;
end;
 
function TWaveObjectStream.WriteWave(const Buffer; Count: Integer): Integer;
begin
Result := Count;
if Position+Count>Size then
SetSize(Size+(Position+Count+Size));
Move(Buffer, Pointer(Integer(FWave.Data)+Position)^, Count);
end;
 
{ TWaveStream }
 
const
ID_RIFF = Ord('R') + Ord('I')*$100 + Ord('F')*$10000 + Ord('F')*$1000000;
ID_WAVE = Ord('W') + Ord('A')*$100 + Ord('V')*$10000 + Ord('E')*$1000000;
ID_FMT = Ord('f') + Ord('m')*$100 + Ord('t')*$10000 + Ord(' ')*$1000000;
ID_FACT = Ord('f') + Ord('a')*$100 + Ord('c')*$10000 + Ord('t')*$1000000;
ID_DATA = Ord('d') + Ord('a')*$100 + Ord('t')*$10000 + Ord('a')*$1000000;
 
type
TWaveFileHeader = packed record
FType: Integer;
Size: Longint;
RType: Integer;
end;
 
TWaveChunkHeader = packed record
CType: Longint;
Size: Longint;
end;
 
constructor TWaveStream.Create(AStream: TStream);
begin
inherited Create;
FStream := AStream;
 
FOriPosition := FStream.Position;
end;
 
destructor TWaveStream.Destroy;
begin
if FOpened and (not FReadMode) then
CloseWriteMode;
inherited Destroy;
end;
 
function TWaveStream.GetSize: Integer;
begin
if FOpened then
begin
if not FReadMode then
Result := FStream.Size-FDataPosition
else
Result := FSize;
end else
Result := 0;
end;
 
function TWaveStream.ReadWave(var Buffer; Count: Integer): Integer;
begin
if not FOpened then
raise EWaveStreamError.Create(SStreamNotOpend);
 
FStream.Position := FDataPosition+Position;
Result := FStream.Read(Buffer, Count);
end;
 
function TWaveStream.WriteWave(const Buffer; Count: Integer): Integer;
begin
if not FOpened then
raise EWaveStreamError.Create(SStreamNotOpend);
 
if FReadMode then
begin
if Position+Count>FSize then
Count := FSize-Position;
end;
 
FStream.Position := FDataPosition+Position;
Result := FStream.Write(Buffer, Count);
end;
 
procedure TWaveStream.Open(WriteMode: Boolean);
begin
if WriteMode then
OpenWriteMode
else
OpenReadMode;
end;
 
procedure TWaveStream.OpenReadMode;
var
WF: TWaveFileHeader;
WC: TWaveChunkHeader;
 
procedure Readfmt; { fmt }
begin
FormatSize := WC.Size;
FStream.ReadBuffer(Format^, WC.Size);
end;
 
procedure Readdata; { data }
begin
FSize := WC.Size;
FDataPosition := FStream.Position;
FStream.Seek(FSize, 1);
end;
 
begin
if FOpened then
raise EWaveStreamError.Create(SStreamOpend);
 
FOpened := True;
FReadMode := True;
 
FStream.Position := FOriPosition;
 
//if FStream.Size-FStream.Position<=0 then Exit;
 
{ File header reading. }
FStream.ReadBuffer(WF, SizeOf(TWaveFileHeader));
 
{ Is it Wave file of the file? }
if (WF.FType<>ID_RIFF) or (WF.RType<>ID_WAVE) then
raise EWaveStreamError.Create(SInvalidWave);
 
{ Chunk reading. }
FillChar(WC, SizeOf(WC), 0);
FStream.Read(WC, SizeOf(TWaveChunkHeader));
while WC.CType<>0 do
begin
case WC.CType of
ID_FMT : Readfmt;
ID_DATA: Readdata;
else
{ Chunk which does not correspond is disregarded. }
FStream.Seek(WC.Size, 1);
end;
 
FillChar(WC, SizeOf(WC), 0);
FStream.Read(WC, SizeOf(TWaveChunkHeader));
end;
end;
 
procedure TWaveStream.OpenWriteMode;
 
procedure WriteFmt; { fmt }
var
WC: TWaveChunkHeader;
begin
with WC do
begin
CType := ID_FMT;
Size := FFormatSize;
end;
 
FStream.WriteBuffer(WC, SizeOf(WC));
FStream.WriteBuffer(FFormat^, FFormatSize);
end;
 
procedure WriteData; { data }
var
WC: TWaveChunkHeader;
begin
FDataHeaderPosition := FStream.Position;
 
with WC do
begin
CType := ID_DATA;
Size := 0;
end;
 
FStream.WriteBuffer(WC, SizeOf(WC));
 
FDataPosition := FStream.Position;
end;
 
var
WF: TWaveFileHeader;
begin
if FOpened then
raise EWaveStreamError.Create(SStreamOpend);
 
if FormatSize=0 then
raise EWaveStreamError.Create(SInvalidWaveFormat);
 
FOpened := True;
FStream.Position := FOriPosition;
 
FStream.WriteBuffer(WF, SizeOf(TWaveFileHeader));
 
{ Chunk writing. }
WriteFmt;
WriteData;
end;
 
procedure TWaveStream.CloseWriteMode;
 
procedure WriteDataHeader; { data }
var
WC: TWaveChunkHeader;
begin
FStream.Position := FDataHeaderPosition;
 
with WC do
begin
CType := ID_DATA;
Size := Self.Size;
end;
 
FStream.WriteBuffer(WC, SizeOf(WC));
end;
 
var
WF: TWaveFileHeader;
begin
with WF do
begin
FType := ID_RIFF;
Size := (FStream.Size-FOriPosition)-SizeOf(TWaveChunkHeader);
RType := ID_WAVE;
end;
FStream.Position := FOriPosition;
FStream.WriteBuffer(WF, SizeOf(TWaveFileHeader));
WriteDataHeader;
FStream.Position := FStream.Size;
end;
 
{ TWaveFileStream }
 
constructor TWaveFileStream.Create(const FileName: string; FileMode: Integer);
begin
FFileStream := TFileStream.Create(FileName, FileMode);
inherited Create(FFileStream);
end;
 
destructor TWaveFileStream.Destroy;
begin
inherited Destroy;
FFileStream.Free;
end;
 
end.
<
/VCL_DELPHIX_D6/DirectX.pas
25,111 → 25,118
* URL : http://www.infosakyu.ne.jp/~kazuya-y/index.html
*
***************************************************************************)
{
(c)2004 Jaro Benes Recompilation with Erik Unger's headers
 
Join in order:
1) DirectDraw
2) Direct3D
3) Direct3DRM
4) DirectInput
5) DirectPlay
6) DirectSetup
7) DirectSound
8) DirectMusic
}
Unit DirectX;
unit DirectX;
 
Interface
interface
 
{Delphi version marks}
{$Z4}
{$A+}
{$WEAKPACKAGEUNIT}
 
{$I DelphiXcfg.inc}
{$IFNDEF DirectX3}
{$IFNDEF DirectX5}
{$IFNDEF DirectX6}
{$IFNDEF DirectX7}
{$DEFINE DirectX7}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
 
{$MINENUMSIZE 4}
{$ALIGN ON}
{$IFDEF DirectX3}
{$UNDEF DirectX5}
{$UNDEF DirectX6}
{$UNDEF DirectX7}
{$DEFINE SupportDirectX3}
{$ENDIF}
 
uses
Windows, MMSystem;
//DirectDraw file
{$IFDEF DirectX5}
{$UNDEF DirectX3}
{$UNDEF DirectX6}
{$UNDEF DirectX7}
{$DEFINE SupportDirectX3}
{$DEFINE SupportDirectX5}
{$ENDIF}
 
{$IFDEF DirectX6}
{$UNDEF DirectX3}
{$UNDEF DirectX5}
{$UNDEF DirectX7}
{$DEFINE SupportDirectX3}
{$DEFINE SupportDirectX5}
{$DEFINE SupportDirectX6}
{$ENDIF}
 
{$IFDEF DirectX7}
{$UNDEF DirectX3}
{$UNDEF DirectX5}
{$UNDEF DirectX6}
{$DEFINE SupportDirectX3}
{$DEFINE SupportDirectX5}
{$DEFINE SupportDirectX6}
{$DEFINE SupportDirectX7}
{$ENDIF}
 
uses Windows, MMSystem, ActiveX;
 
const
{$IFDEF DirectX3}
DirectXUnitVersion = 3;
{$ENDIF}{$IFDEF DirectX5}
DirectXUnitVersion = 5;
{$ENDIF}{$IFDEF DirectX6}
DirectXUnitVersion = 6;
{$ENDIF}{$IFDEF DirectX7}
DirectXUnitVersion = 7;
{$ENDIF}
 
(*==========================================================================;
*
* Copyright (C) 1994-1997 Microsoft Corporation. All Rights Reserved.
* Copyright (C) Microsoft Corporation. All Rights Reserved.
*
* Files: ddraw.h dvp.h
* Content: DirectDraw and DirectDrawVideoPort include files
* File: ddraw.h
* Content: DirectDraw include file
*
* DirectX 7.0 Delphi adaptation by Erik Unger
*
* Modified: 10-Sep-2000
*
* Download: http://www.delphi-jedi.org/DelphiGraphics/
* E-Mail: DelphiDirectX@next-reality.com
*
*
***************************************************************************)
 
var
DDrawDLL : HMODULE = 0;
{ FOURCC codes for DX compressed-texture pixel formats }
 
function DDErrorString(Value: HResult) : string;
const
FOURCC_DXT1 = Ord('D') + Ord('X') shl 8 + Ord('T') shl 16 + Ord('1') shl 24;
FOURCC_DXT2 = Ord('D') + Ord('X') shl 8 + Ord('T') shl 16 + Ord('2') shl 24;
FOURCC_DXT3 = Ord('D') + Ord('X') shl 8 + Ord('T') shl 16 + Ord('3') shl 24;
FOURCC_DXT4 = Ord('D') + Ord('X') shl 8 + Ord('T') shl 16 + Ord('4') shl 24;
FOURCC_DXT5 = Ord('D') + Ord('X') shl 8 + Ord('T') shl 16 + Ord('5') shl 24;
 
function MAKEFOURCC(ch0, ch1, ch2, ch3: Char) : DWORD;
{ GUIDS used by DirectDraw objects }
 
(*
* FOURCC codes for DX compressed-texture pixel formats
*)
const
FOURCC_DXT1 = 'DXT1';
FOURCC_DXT2 = 'DXT2';
FOURCC_DXT3 = 'DXT3';
FOURCC_DXT4 = 'DXT4';
FOURCC_DXT5 = 'DXT5';
 
(*
* GUIDS used by DirectDraw objects
*)
const
CLSID_DirectDraw: TGUID = '{D7B70EE0-4340-11CF-B063-0020AFC2CD35}';
CLSID_DirectDraw7: TGUID = '{3c305196-50db-11d3-9cfe-00c04fd930c5}';
CLSID_DirectDrawClipper: TGUID = '{593817A0-7DB3-11CF-A2DE-00AA00b93356}';
CLSID_DirectDraw7: TGUID = '{3C305196-50DB-11D3-9CFE-00C04FD930C5}';
CLSID_DirectDrawClipper: TGUID = '{593817A0-7DB3-11CF-A2DE-00AA00B93356}';
IID_IDirectDraw: TGUID = '{6C14DB80-A733-11CE-A521-0020AF0BE560}';
IID_IDirectDraw2: TGUID = '{B3A6F3E0-2B43-11CF-A2DE-00AA00B93356}';
IID_IDirectDraw4: TGUID = '{9C59509A-39BD-11D1-8C4A-00C04FD930C5}';
IID_IDirectDraw7: TGUID = '{15E65EC0-3B9C-11D2-B92F-00609797EA5B}';
IID_IDirectDrawSurface: TGUID = '{6C14DB81-A733-11CE-A521-0020AF0BE560}';
IID_IDirectDrawSurface2: TGUID = '{57805885-6EEC-11CF-9441-A82303C10E27}';
IID_IDirectDrawSurface3: TGUID = '{DA044E00-69B2-11D0-A1D5-00AA00B8DFBB}';
IID_IDirectDrawSurface4: TGUID = '{0B2B8630-AD35-11D0-8EA6-00609797EA5B}';
IID_IDirectDrawSurface7: TGUID = '{06675A80-3B9B-11D2-B92F-00609797EA5B}';
IID_IDirectDrawPalette: TGUID = '{6C14DB84-A733-11CE-A521-0020AF0BE560}';
IID_IDirectDrawClipper: TGUID = '{6C14DB85-A733-11CE-A521-0020AF0BE560}';
IID_IDirectDrawColorControl: TGUID = '{4B9F0EE0-0D7E-11D0-9B06-00A0C903A3B8}';
IID_IDirectDrawGammaControl: TGUID = '{69C11C3E-B46B-11D1-AD7A-00C04FC29B4E}';
 
const
DD_ROP_SPACE = (256 div 32); // space required to store ROP array
DD_ROP_SPACE = 256 div 32; // space required to store ROP array
 
MAX_DDDEVICEID_STRING = 512;
 
(*
* Flags for the IDirectDraw4::GetDeviceIdentifier method
*)
{ DirectDraw Structures }
 
(*
* This flag causes GetDeviceIdentifier to return information about the host (typically 2D) adapter in a system equipped
* with a stacked secondary 3D adapter. Such an adapter appears to the application as if it were part of the
* host adapter, but is typically physcially located on a separate card. The stacked secondary's information is
* returned when GetDeviceIdentifier's dwFlags field is zero, since this most accurately reflects the qualities
* of the DirectDraw object involved.
*)
DDGDI_GETHOSTIDENTIFIER = $00000001;
 
(*============================================================================
*
* DirectDraw Structures
*
* Various structures used to invoke DirectDraw.
*
*==========================================================================*)
 
var
NilGUID : TGUID{$IfNDef VER6UP} absolute 0{$EndIf};
 
type
TRefGUID = packed record
case integer of
1: (guid : PGUID);
2: (dwFlags : DWORD);
end;
 
IDirectDraw = interface;
IDirectDraw2 = interface;
IDirectDraw4 = interface;
139,40 → 146,41
IDirectDrawSurface3 = interface;
IDirectDrawSurface4 = interface;
IDirectDrawSurface7 = interface;
 
IDirectDrawPalette = interface;
IDirectDrawClipper = interface;
IDirectDrawColorControl = interface;
IDirectDrawGammaControl = interface;
 
(*
* Generic pixel format with 8-bit RGB and alpha components
*)
{ TDDARGB structure }
 
PDDARGB = ^TDDARGB;
TDDARGB = packed record
blue: BYTE;
green: BYTE;
red: BYTE;
alpha: BYTE;
TDDARGB = record
Blue: Byte;
Green: Byte;
Red: Byte;
Alpha: Byte;
end;
 
(*
* This version of the structure remains for backwards source compatibility.
* The DDARGB structure is the one that should be used for all DirectDraw APIs.
*)
DDARGB = TDDARGB;
LPDDARGB = PDDARGB;
 
{ TDDRGBA structure }
 
PDDRGBA = ^TDDRGBA;
TDDRGBA = packed record
red : BYTE;
green : BYTE;
blue : BYTE;
alpha : BYTE;
TDDRGBA = record
Red: Byte;
Green: Byte;
Blue: Byte;
Alpha: Byte;
end;
 
(*
* TDDColorKey
*)
DDRGBA = TDDRGBA;
LPDDRGBA = PDDRGBA;
 
{ TDDColorKey structure }
 
PDDColorKey = ^TDDColorKey;
TDDColorKey = packed record
TDDColorKey = record
dwColorSpaceLowValue: DWORD; // low boundary of color space that is to
// be treated as Color Key, inclusive
dwColorSpaceHighValue: DWORD; // high boundary of color space that is
179,21 → 187,13
// to be treated as Color Key, inclusive
end;
 
// Delphi 5 can't handle interface in variant records
// so we have to use pointers instead (which can be type-casted into interfaces):
DDCOLORKEY = TDDColorKey;
LPDDCOLORKEY = PDDColorKey;
 
{$IFDEF VER5UP}
PDirectDrawSurface = Pointer;
{$ELSE}
PDirectDrawSurface = IDirectDrawSurface;
{$ENDIF}
{ TDDBltFX structure }
 
(*
* TDDBltFX
* Used to pass override information to the DIRECTDRAWSURFACE callback Blt.
*)
PDDBltFX = ^TDDBltFX;
TDDBltFX = packed record
TDDBltFX = record
dwSize : DWORD; // size of structure
dwDDFX : DWORD; // FX operations
dwROP : DWORD; // Win32 raster operations
204,88 → 204,89
dwZBufferHigh : DWORD; // High limit of Z buffer
dwZBufferBaseDest : DWORD; // Destination base value
dwZDestConstBitDepth : DWORD; // Bit depth used to specify Z constant for destination
case integer of
case Integer of
0: (
dwZDestConst : DWORD // Constant to use as Z buffer for dest
);
1: (
lpDDSZBufferDest : PDirectDrawSurface; // Surface to use as Z buffer for dest
dwZDestConst: DWORD; // Constant to use as Z buffer for dest
dwZSrcConstBitDepth : DWORD; // Bit depth used to specify Z constant for source
case integer of
0: (
dwZSrcConst : DWORD; // Constant to use as Z buffer for src
);
1: (
lpDDSZBufferSrc : PDirectDrawSurface; // Surface to use as Z buffer for src
dwAlphaEdgeBlendBitDepth : DWORD; // Bit depth used to specify constant for alpha edge blend
dwAlphaEdgeBlend : DWORD; // Alpha for edge blending
dwReserved : DWORD;
dwAlphaDestConstBitDepth : DWORD; // Bit depth used to specify alpha constant for destination
case integer of
0: (
dwAlphaDestConst : DWORD; // Constant to use as Alpha Channel
);
1: (
lpDDSAlphaDest : PDirectDrawSurface; // Surface to use as Alpha Channel
dwAlphaSrcConstBitDepth : DWORD; // Bit depth used to specify alpha constant for source
case integer of
0: (
dwAlphaSrcConst : DWORD; // Constant to use as Alpha Channel
);
1: (
lpDDSAlphaSrc : PDirectDrawSurface; // Surface to use as Alpha Channel
case integer of
0: (
dwFillColor : DWORD; // color in RGB or Palettized
ddckDestColorkey: TDDColorKey; // DestColorkey override
ddckSrcColorkey: TDDColorKey; // SrcColorkey override
);
1: (
lpDDSZBufferDest: Pointer{IDirectDrawSurface}; // Surface to use as Z buffer for dest
_union1b: DWORD;
lpDDSZBufferSrc: Pointer{IDirectDrawSurface}; // Surface to use as Z buffer for src
_union1d: DWORD;
_union1e: DWORD;
_union1f: DWORD;
_union1g: DWORD;
lpDDSAlphaDest: Pointer{IDirectDrawSurface}; // Surface to use as Alpha Channel
_union1i: DWORD;
lpDDSAlphaSrc: Pointer{IDirectDrawSurface}; // Surface to use as Alpha Channel
dwFillDepth : DWORD; // depth value for z-buffer
);
2: (
dwFillPixel : DWORD; // pixel value
_union2a: DWORD;
_union2b: DWORD;
_union2c: DWORD;
_union2d: DWORD;
_union2e: DWORD;
_union2f: DWORD;
_union2g: DWORD;
_union2h: DWORD;
_union2i: DWORD;
_union2j: DWORD;
lpDDSPattern: Pointer{IDirectDrawSurface}; // Surface to use as pattern
);
3: (
lpDDSPattern : PDirectDrawSurface; // Surface to use as pattern
ddckDestColorkey : TDDColorKey; // DestColorkey override
ddckSrcColorkey : TDDColorKey; // SrcColorkey override
)
)
)
)
)
end;
 
(*
* TDDSCaps
*)
DDBLTFX = TDDBltFX;
LPDDBLTFX = PDDBltFX;
 
{ TDDSCaps structure }
 
PDDSCaps = ^TDDSCaps;
TDDSCaps = packed record
TDDSCaps = record
dwCaps: DWORD; // capabilities of surface wanted
end;
 
(*
* TDDOSCaps
*)
DDSCAPS = TDDSCaps;
LPDDSCAPS = PDDSCaps;
{ TDDOSCaps structure }
 
PDDOSCaps = ^TDDOSCaps;
TDDOSCaps = packed record
TDDOSCaps = record
dwCaps: DWORD; // capabilities of surface wanted
end;
 
(*
* This structure is used internally by DirectDraw.
*)
DDOSCAPS = TDDOSCaps;
LPDDOSCAPS = PDDOSCaps;
 
 
{ TDDSCapsEx structure }
 
PDDSCapsEx = ^TDDSCapsEx;
TDDSCapsEx = packed record
TDDSCapsEx = record
dwCaps2 : DWORD;
dwCaps3 : DWORD;
dwCaps4 : DWORD;
end;
 
(*
* TDDSCaps2
*)
DDSCAPSEX = TDDSCapsEx;
LPDDSCAPSEX = PDDSCapsEx;
 
{ TDDSCaps2 structure }
 
PDDSCaps2 = ^TDDSCaps2;
TDDSCaps2 = packed record
TDDSCaps2 = record
dwCaps: DWORD; // capabilities of surface wanted
dwCaps2 : DWORD;
dwCaps3 : DWORD;
292,15 → 293,53
dwCaps4 : DWORD;
end;
 
(*
* TDDCaps
*)
(*
* This structure is the TDDCaps structure as it was in version 2 and 3 of Direct X.
* It is present for back compatability.
*)
DDSCAPS2 = TDDSCaps2;
LPDDSCAPS2 = PDDSCaps2;
 
{ TDDCaps structure }
 
PDDCaps_DX1 = ^TDDCaps_DX1;
TDDCaps_DX1 = record
dwSize: DWORD; // size of the DDDRIVERCAPS structure
dwCaps: DWORD; // driver specific capabilities
dwCaps2: DWORD; // more driver specific capabilites
dwCKeyCaps: DWORD; // color key capabilities of the surface
dwFXCaps: DWORD; // driver specific stretching and effects capabilites
dwFXAlphaCaps: DWORD; // alpha driver specific capabilities
dwPalCaps: DWORD; // palette capabilities
dwSVCaps: DWORD; // stereo vision capabilities
dwAlphaBltConstBitDepths: DWORD; // DDBD_2,4,8
dwAlphaBltPixelBitDepths: DWORD; // DDBD_1,2,4,8
dwAlphaBltSurfaceBitDepths: DWORD; // DDBD_1,2,4,8
dwAlphaOverlayConstBitDepths: DWORD; // DDBD_2,4,8
dwAlphaOverlayPixelBitDepths: DWORD; // DDBD_1,2,4,8
dwAlphaOverlaySurfaceBitDepths: DWORD; // DDBD_1,2,4,8
dwZBufferBitDepths: DWORD; // DDBD_8,16,24,32
dwVidMemTotal: DWORD; // total amount of video memory
dwVidMemFree: DWORD; // amount of free video memory
dwMaxVisibleOverlays: DWORD; // maximum number of visible overlays
dwCurrVisibleOverlays: DWORD; // current number of visible overlays
dwNumFourCCCodes: DWORD; // number of four cc codes
dwAlignBoundarySrc: DWORD; // source rectangle alignment
dwAlignSizeSrc: DWORD; // source rectangle byte size
dwAlignBoundaryDest: DWORD; // dest rectangle alignment
dwAlignSizeDest: DWORD; // dest rectangle byte size
dwAlignStrideAlign: DWORD; // stride alignment
dwRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
ddsCaps: TDDSCaps; // TDDSCaps structure has all the general capabilities
dwMinOverlayStretch: DWORD; // minimum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxOverlayStretch: DWORD; // maximum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMinLiveVideoStretch: DWORD; // minimum live video stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxLiveVideoStretch: DWORD; // maximum live video stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMinHwCodecStretch: DWORD; // minimum hardware codec stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxHwCodecStretch: DWORD; // maximum hardware codec stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwReserved1: DWORD; // reserved
dwReserved2: DWORD; // reserved
dwReserved3: DWORD; // reserved
end;
 
PDDCaps_DX3 = ^TDDCaps_DX3;
TDDCaps_DX3 = packed record
TDDCaps_DX3 = record
dwSize: DWORD; // size of the DDDRIVERCAPS structure
dwCaps: DWORD; // driver specific capabilities
dwCaps2: DWORD; // more driver specific capabilites
326,7 → 365,7
dwAlignBoundaryDest: DWORD; // dest rectangle alignment
dwAlignSizeDest: DWORD; // dest rectangle byte size
dwAlignStrideAlign: DWORD; // stride alignment
dwRops: Array [0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
dwRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
ddsCaps: TDDSCaps; // TDDSCaps structure has all the general capabilities
dwMinOverlayStretch: DWORD; // minimum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxOverlayStretch: DWORD; // maximum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
340,26 → 379,22
dwSVBCaps: DWORD; // driver specific capabilities for System->Vmem blts
dwSVBCKeyCaps: DWORD; // driver color key capabilities for System->Vmem blts
dwSVBFXCaps: DWORD; // driver FX capabilities for System->Vmem blts
dwSVBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwSVBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwVSBCaps: DWORD; // driver specific capabilities for Vmem->System blts
dwVSBCKeyCaps: DWORD; // driver color key capabilities for Vmem->System blts
dwVSBFXCaps: DWORD; // driver FX capabilities for Vmem->System blts
dwVSBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwVSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwSSBCaps: DWORD; // driver specific capabilities for System->System blts
dwSSBCKeyCaps: DWORD; // driver color key capabilities for System->System blts
dwSSBFXCaps: DWORD; // driver FX capabilities for System->System blts
dwSSBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
dwReserved4 : DWORD;
dwReserved5 : DWORD;
dwReserved6 : DWORD;
dwSSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
dwReserved4: DWORD; // reserved
dwReserved5: DWORD; // reserved
dwReserved6: DWORD; // reserved
end;
 
(*
* This structure is the TDDCaps structure as it was in version 5 of Direct X.
* It is present for back compatability.
*)
PDDCaps_DX5 = ^TDDCaps_DX5;
TDDCaps_DX5 = packed record
TDDCaps_DX5 = record
dwSize: DWORD; // size of the DDDRIVERCAPS structure
dwCaps: DWORD; // driver specific capabilities
dwCaps2: DWORD; // more driver specific capabilites
385,7 → 420,7
dwAlignBoundaryDest: DWORD; // dest rectangle alignment
dwAlignSizeDest: DWORD; // dest rectangle byte size
dwAlignStrideAlign: DWORD; // stride alignment
dwRops: Array [0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
dwRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
ddsCaps: TDDSCaps; // TDDSCaps structure has all the general capabilities
dwMinOverlayStretch: DWORD; // minimum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxOverlayStretch: DWORD; // maximum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
399,16 → 434,16
dwSVBCaps: DWORD; // driver specific capabilities for System->Vmem blts
dwSVBCKeyCaps: DWORD; // driver color key capabilities for System->Vmem blts
dwSVBFXCaps: DWORD; // driver FX capabilities for System->Vmem blts
dwSVBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwSVBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwVSBCaps: DWORD; // driver specific capabilities for Vmem->System blts
dwVSBCKeyCaps: DWORD; // driver color key capabilities for Vmem->System blts
dwVSBFXCaps: DWORD; // driver FX capabilities for Vmem->System blts
dwVSBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwVSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwSSBCaps: DWORD; // driver specific capabilities for System->System blts
dwSSBCKeyCaps: DWORD; // driver color key capabilities for System->System blts
dwSSBFXCaps: DWORD; // driver FX capabilities for System->System blts
dwSSBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
// Members added for DX5:
dwSSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
{ Members added for DX5 }
dwMaxVideoPorts: DWORD; // maximum number of usable video ports
dwCurrVideoPorts: DWORD; // current number of video ports used
dwSVBCaps2: DWORD; // more driver specific capabilities for System->Vmem blts
416,16 → 451,79
dwNLVBCaps2: DWORD; // more driver specific capabilities non-local->local vidmem blts
dwNLVBCKeyCaps: DWORD; // driver color key capabilities for non-local->local vidmem blts
dwNLVBFXCaps: DWORD; // driver FX capabilities for non-local->local blts
dwNLVBRops: Array [0..DD_ROP_SPACE-1] of DWORD; // ROPS supported for non-local->local blts
dwNLVBRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported for non-local->local blts
end;
 
PDDCaps_DX6 = ^TDDCaps_DX6;
TDDCaps_DX6 = packed record
TDDCaps_DX6 = record
dwSize: DWORD; // size of the DDDRIVERCAPS structure
dwCaps: DWORD; // driver specific capabilities
dwCaps2: DWORD; // more driver specific capabilites
dwCKeyCaps: DWORD; // color key capabilities of the surface
dwFXCaps: DWORD; // driver specific stretching and effects capabilites
dwFXAlphaCaps: DWORD; // alpha caps
dwPalCaps: DWORD; // palette capabilities
dwSVCaps: DWORD; // stereo vision capabilities
dwAlphaBltConstBitDepths: DWORD; // DDBD_2,4,8
dwAlphaBltPixelBitDepths: DWORD; // DDBD_1,2,4,8
dwAlphaBltSurfaceBitDepths: DWORD; // DDBD_1,2,4,8
dwAlphaOverlayConstBitDepths: DWORD; // DDBD_2,4,8
dwAlphaOverlayPixelBitDepths: DWORD; // DDBD_1,2,4,8
dwAlphaOverlaySurfaceBitDepths: DWORD; // DDBD_1,2,4,8
dwZBufferBitDepths: DWORD; // DDBD_8,16,24,32
dwVidMemTotal: DWORD; // total amount of video memory
dwVidMemFree: DWORD; // amount of free video memory
dwMaxVisibleOverlays: DWORD; // maximum number of visible overlays
dwCurrVisibleOverlays: DWORD; // current number of visible overlays
dwNumFourCCCodes: DWORD; // number of four cc codes
dwAlignBoundarySrc: DWORD; // source rectangle alignment
dwAlignSizeSrc: DWORD; // source rectangle byte size
dwAlignBoundaryDest: DWORD; // dest rectangle alignment
dwAlignSizeDest: DWORD; // dest rectangle byte size
dwAlignStrideAlign: DWORD; // stride alignment
dwRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
ddsOldCaps: TDDSCaps; // Was TDDSCaps ddsCaps. ddsCaps is of type DDSCAPS2 for DX6
dwMinOverlayStretch: DWORD; // minimum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxOverlayStretch: DWORD; // maximum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMinLiveVideoStretch: DWORD; // minimum live video stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxLiveVideoStretch: DWORD; // maximum live video stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMinHwCodecStretch: DWORD; // minimum hardware codec stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxHwCodecStretch: DWORD; // maximum hardware codec stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwReserved1: DWORD; // reserved
dwReserved2: DWORD; // reserved
dwReserved3: DWORD; // reserved
dwSVBCaps: DWORD; // driver specific capabilities for System->Vmem blts
dwSVBCKeyCaps: DWORD; // driver color key capabilities for System->Vmem blts
dwSVBFXCaps: DWORD; // driver FX capabilities for System->Vmem blts
dwSVBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwVSBCaps: DWORD; // driver specific capabilities for Vmem->System blts
dwVSBCKeyCaps: DWORD; // driver color key capabilities for Vmem->System blts
dwVSBFXCaps: DWORD; // driver FX capabilities for Vmem->System blts
dwVSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwSSBCaps: DWORD; // driver specific capabilities for System->System blts
dwSSBCKeyCaps: DWORD; // driver color key capabilities for System->System blts
dwSSBFXCaps: DWORD; // driver FX capabilities for System->System blts
dwSSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
{ Members added for DX5 }
dwMaxVideoPorts: DWORD; // maximum number of usable video ports
dwCurrVideoPorts: DWORD; // current number of video ports used
dwSVBCaps2: DWORD; // more driver specific capabilities for System->Vmem blts
dwNLVBCaps: DWORD; // driver specific capabilities for non-local->local vidmem blts
dwNLVBCaps2: DWORD; // more driver specific capabilities non-local->local vidmem blts
dwNLVBCKeyCaps: DWORD; // driver color key capabilities for non-local->local vidmem blts
dwNLVBFXCaps: DWORD; // driver FX capabilities for non-local->local blts
dwNLVBRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported for non-local->local blts
{ Members added for DX6 }
ddsCaps: TDDSCaps2; // Surface Caps
end;
 
PDDCaps_DX7 = ^TDDCaps_DX7;
TDDCaps_DX7 = record
dwSize: DWORD; // size of the DDDRIVERCAPS structure
dwCaps: DWORD; // driver specific capabilities
dwCaps2: DWORD; // more driver specific capabilites
dwCKeyCaps: DWORD; // color key capabilities of the surface
dwFXCaps: DWORD; // driver specific stretching and effects capabilites
dwFXAlphaCaps: DWORD; // alpha driver specific capabilities
dwPalCaps: DWORD; // palette capabilities
dwSVCaps: DWORD; // stereo vision capabilities
446,8 → 544,8
dwAlignBoundaryDest: DWORD; // dest rectangle alignment
dwAlignSizeDest: DWORD; // dest rectangle byte size
dwAlignStrideAlign: DWORD; // stride alignment
dwRops: Array [0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
ddsOldCaps: TDDSCaps; // Was dssCaps: TDDSCaps. ddsCaps is of type TDDScaps2 for DX6
dwRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported
ddsOldCaps: TDDSCaps; // Was TDDSCaps ddsCaps. ddsCaps is of type DDSCAPS2 for DX6
dwMinOverlayStretch: DWORD; // minimum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMaxOverlayStretch: DWORD; // maximum overlay stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
dwMinLiveVideoStretch: DWORD; // minimum live video stretch factor multiplied by 1000, eg 1000 == 1.0, 1300 == 1.3
460,16 → 558,16
dwSVBCaps: DWORD; // driver specific capabilities for System->Vmem blts
dwSVBCKeyCaps: DWORD; // driver color key capabilities for System->Vmem blts
dwSVBFXCaps: DWORD; // driver FX capabilities for System->Vmem blts
dwSVBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwSVBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->Vmem blts
dwVSBCaps: DWORD; // driver specific capabilities for Vmem->System blts
dwVSBCKeyCaps: DWORD; // driver color key capabilities for Vmem->System blts
dwVSBFXCaps: DWORD; // driver FX capabilities for Vmem->System blts
dwVSBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwVSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for Vmem->System blts
dwSSBCaps: DWORD; // driver specific capabilities for System->System blts
dwSSBCKeyCaps: DWORD; // driver color key capabilities for System->System blts
dwSSBFXCaps: DWORD; // driver FX capabilities for System->System blts
dwSSBRops: Array [0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
// Members added for DX5:
dwSSBRops: array[0..DD_ROP_SPACE-1] of DWORD;// ROPS supported for System->System blts
{ Members added for DX5 }
dwMaxVideoPorts: DWORD; // maximum number of usable video ports
dwCurrVideoPorts: DWORD; // current number of video ports used
dwSVBCaps2: DWORD; // more driver specific capabilities for System->Vmem blts
477,48 → 575,40
dwNLVBCaps2: DWORD; // more driver specific capabilities non-local->local vidmem blts
dwNLVBCKeyCaps: DWORD; // driver color key capabilities for non-local->local vidmem blts
dwNLVBFXCaps: DWORD; // driver FX capabilities for non-local->local blts
dwNLVBRops: Array [0..DD_ROP_SPACE-1] of DWORD; // ROPS supported for non-local->local blts
// Members added for DX6 release
dwNLVBRops: array[0..DD_ROP_SPACE-1] of DWORD; // ROPS supported for non-local->local blts
{ Members added for DX6 }
ddsCaps : TDDSCaps2 ; // Surface Caps
end;
 
TDDCaps_DX7 = TDDCaps_DX6;
PDDCaps = ^TDDCaps;
 
{$IFDEF DIRECTX3}
{$IFDEF DirectX1}
TDDCaps = TDDCaps_DX1;
PDDCaps = PDDCaps_DX1;
{$ENDIF}{$IFDEF DirectX3}
TDDCaps = TDDCaps_DX3;
{$ELSE}
{$IFDEF DIRECTX5}
PDDCaps = PDDCaps_DX3;
{$ENDIF}{$IFDEF DirectX5}
TDDCaps = TDDCaps_DX5;
{$ELSE}
{$IFDEF DIRECTX6}
PDDCaps = PDDCaps_DX5;
{$ENDIF}{$IFDEF DirectX6}
TDDCaps = TDDCaps_DX6;
{$ELSE}
PDDCaps = PDDCaps_DX6;
{$ENDIF}{$IFDEF DirectX7}
TDDCaps = TDDCaps_DX7;
PDDCaps = PDDCaps_DX7;
{$ENDIF}
{$ENDIF}
{$ENDIF}
 
DDCAPS = TDDCaps;
LPDDCAPS = PDDCaps;
 
{ TDDPixelFormat structure }
 
 
(*
* TDDPixelFormat
*)
PDDPixelFormat_DX5 = ^TDDPixelFormat_DX5;
TDDPixelFormat_DX5 = packed record
PDDPixelFormat = ^TDDPixelFormat;
TDDPixelFormat = record
dwSize: DWORD; // size of structure
dwFlags: DWORD; // pixel format flags
dwFourCC: DWORD; // (FOURCC code)
case Integer of
0: (
dwZBufferBitDepth: DWORD; // how many bits for z buffers
);
1: (
dwAlphaBitDepth: DWORD; // how many bits for alpha channels
);
2: (
dwRGBBitCount: DWORD; // how many bits per pixel
dwRBitMask: DWORD; // mask for red bit
dwGBitMask: DWORD; // mask for green bits
525,38 → 615,14
dwBBitMask: DWORD; // mask for blue bits
dwRGBAlphaBitMask: DWORD; // mask for alpha channel
);
3: (
dwYUVBitCount: DWORD; // how many bits per pixel
dwYBitMask: DWORD; // mask for Y bits
dwUBitMask: DWORD; // mask for U bits
dwVBitMask: DWORD; // mask for V bits
case Integer of
0: (
dwYUVAlphaBitMask: DWORD; // mask for alpha channel
);
1: (
dwRGBZBitMask: DWORD;
_union1a: DWORD;
_union1b: DWORD;
_union1c: DWORD;
_union1d: DWORD;
dwRGBZBitMask: DWORD; // mask for Z channel
);
2: (
dwYUVZBitMask: DWORD;
);
);
end;
 
PDDPixelFormat_DX6 = ^TDDPixelFormat_DX6;
TDDPixelFormat_DX6 = packed record
dwSize: DWORD; // size of structure
dwFlags: DWORD; // pixel format flags
dwFourCC: DWORD; // (FOURCC code)
case Integer of
1: (
dwRGBBitCount : DWORD; // how many bits per pixel
dwRBitMask : DWORD; // mask for red bit
dwGBitMask : DWORD; // mask for green bits
dwBBitMask : DWORD; // mask for blue bits
dwRGBAlphaBitMask : DWORD; // mask for alpha channel
);
2: (
dwYUVBitCount : DWORD; // how many bits per pixel
dwYBitMask : DWORD; // mask for Y bits
dwUBitMask : DWORD; // mask for U bits
564,52 → 630,43
dwYUVAlphaBitMask : DWORD; // mask for alpha channel
);
3: (
dwZBufferBitDepth : DWORD; // how many total bits/pixel in z buffer (including any stencil bits)
_union3a: DWORD;
_union3b: DWORD;
_union3c: DWORD;
_union3d: DWORD;
dwYUVZBitMask: DWORD; // mask for Z channel
);
4: (
dwZBufferBitDepth: DWORD; // how many bits for z buffers
dwStencilBitDepth : DWORD; // how many stencil bits (note: dwZBufferBitDepth-dwStencilBitDepth is total Z-only bits)
dwZBitMask : DWORD; // mask for Z bits
dwStencilBitMask : DWORD; // mask for stencil bits
dwLuminanceAlphaBitMask : DWORD;// mask for alpha channel
);
4: (
5: (
dwAlphaBitDepth : DWORD; // how many bits for alpha channels
);
6: (
dwLuminanceBitCount: DWORD; // how many bits per pixel
dwLuminanceBitMask : DWORD; // mask for luminance bits
_union6c: DWORD;
_union6d: DWORD;
dwLuminanceAlphaBitMask: DWORD;
);
7: (
dwBumpBitCount: DWORD; // how many bits per "buxel", total
dwBumpDuBitMask: DWORD; // mask for bump map U delta bits
dwBumpDvBitMask : DWORD; // mask for bump map V delta bits
dwBumpLuminanceBitMask : DWORD; // mask for luminance in bump map
dwRGBZBitMask : DWORD; // mask for Z channel
);
5: (
dwLuminanceBitCount : DWORD; // how many bits per pixel
dwBumpDuBitMask : DWORD; // mask for bump map U delta bits
Fill1, Fill2 : DWORD;
dwYUVZBitMask : DWORD; // mask for Z channel
);
6: ( dwBumpBitCount : DWORD; // how many bits per "buxel", total
);
end;
 
TDDPixelFormat_DX3 = TDDPixelFormat_DX5;
TDDPixelFormat_DX7 = TDDPixelFormat_DX6;
DDPIXELFORMAT = TDDPixelFormat;
LPDDPIXELFORMAT = PDDPixelFormat;
 
PDDPixelFormat = ^TDDPixelFormat;
{$IFDEF DIRECTX3}
TDDPixelFormat = TDDPixelFormat_DX3;
{$ELSE}
{$IFDEF DIRECTX5}
TDDPixelFormat = TDDPixelFormat_DX5;
{$ELSE}
{$IFDEF DIRECTX6}
TDDPixelFormat = TDDPixelFormat_DX6;
{$ELSE}
TDDPixelFormat = TDDPixelFormat_DX7;
{$ENDIF}
{$ENDIF}
{$ENDIF}
{ DDOVERLAYFX structure }
 
(*
* TDDOverlayFX
*)
PDDOverlayFX = ^TDDOverlayFX;
TDDOverlayFX = packed record
PDDOverlayFx = ^TDDOverlayFx;
TDDOverlayFx = record
dwSize: DWORD; // size of structure
dwAlphaEdgeBlendBitDepth: DWORD; // Bit depth used to specify constant for alpha edge blend
dwAlphaEdgeBlend: DWORD; // Constant to use as alpha for edge blend
626,40 → 683,157
dwFlags: DWORD; // flags
);
1: (
lpDDSAlphaDest: PDirectDrawSurface; // Surface to use as alpha channel for dest
filler: DWORD;
lpDDSAlphaSrc: PDirectDrawSurface; // Surface to use as alpha channel for src
lpDDSAlphaDest: Pointer{IDirectDrawSurface}; // Surface to use as alpha channel for dest
_union1b: DWORD;
lpDDSAlphaSrc: Pointer{IDirectDrawSurface}; // Surface to use as alpha channel for src
);
end;
 
(*
* TDDBltBatch: BltBatch entry structure
*)
DDOVERLAYFX = TDDOverlayFx;
LPDDOVERLAYFX = PDDOverlayFx;
 
{ TDDBltBatch structure }
 
PDDBltBatch = ^TDDBltBatch;
TDDBltBatch = packed record
TDDBltBatch = record
lprDest: PRect;
lpDDSSrc: IDirectDrawSurface;
lprSrc: PRect;
dwFlags: DWORD;
lpDDBltFx: TDDBltFX;
lpDDBltFx: PDDBltFX;
end;
 
(*
* TDDGammaRamp
*)
DDBLTBATCH = TDDBltBatch;
LPDDBLTBATCH = PDDBltBatch;
 
{ TDDSurfaceDesc structure }
 
PDDSurfaceDesc = ^TDDSurfaceDesc;
TDDSurfaceDesc = record
dwSize: DWORD; // size of the TDDSurfaceDesc structure
dwFlags: DWORD; // determines what fields are valid
dwHeight: DWORD; // height of surface to be created
dwWidth: DWORD; // width of input surface
case Integer of
0: (
lPitch: Longint;
dwBackBufferCount: DWORD; // number of back buffers requested
case Integer of
0: (
dwMipMapCount: DWORD; // number of mip-map levels requested
dwAlphaBitDepth: DWORD; // depth of alpha buffer requested
dwReserved: DWORD; // reserved
lpSurface: Pointer; // pointer to the associated surface memory
ddckCKDestOverlay: TDDColorKey;// color key for destination overlay use
ddckCKDestBlt: TDDColorKey; // color key for destination blt use
ddckCKSrcOverlay: TDDColorKey; // color key for source overlay use
ddckCKSrcBlt: TDDColorKey; // color key for source blt use
ddpfPixelFormat: TDDPixelFormat;// pixel format description of the surface
ddsCaps: TDDSCaps; // direct draw surface capabilities
);
1: (
dwZBufferBitDepth: DWORD; // depth of Z buffer requested
);
2: (
dwRefreshRate: DWORD; // refresh rate (used when display mode is described)
);
);
1: (
dwLinearSize: DWORD
);
end;
 
DDSURFACEDESC = TDDSurfaceDesc;
LPDDSURFACEDESC = PDDSurfaceDesc;
 
{ TDDSurfaceDesc2 structure }
 
PDDSurfaceDesc2 = ^TDDSurfaceDesc2;
TDDSurfaceDesc2 = record
dwSize: DWORD; // size of the TDDSurfaceDesc2 structure
dwFlags: DWORD; // determines what fields are valid
dwHeight: DWORD; // height of surface to be created
dwWidth: DWORD; // width of input surface
case Integer of
0: (
lPitch: Longint;
dwBackBufferCount: DWORD; // number of back buffers requested
case Integer of
0: (
dwMipMapCount: DWORD; // number of mip-map levels requested
dwAlphaBitDepth: DWORD; // depth of alpha buffer requested
dwReserved: DWORD; // reserved
lpSurface: Pointer; // pointer to the associated surface memory
ddckCKDestOverlay: TDDColorKey;// color key for destination overlay use
ddckCKDestBlt: TDDColorKey; // color key for destination blt use
ddckCKSrcOverlay: TDDColorKey; // color key for source overlay use
ddckCKSrcBlt: TDDColorKey; // color key for source blt use
ddpfPixelFormat: TDDPixelFormat;// pixel format description of the surface
ddsCaps: TDDSCaps2; // direct draw surface capabilities
dwTextureStage: DWORD; // stage in multitexture cascade
);
1: (
dwRefreshRate: DWORD; // refresh rate (used when display mode is described)
);
);
1: (
dwLinearSize: DWORD
);
end;
 
DDSURFACEDESC2 = TDDSurfaceDesc2;
LPDDSURFACEDESC2 = PDDSurfaceDesc2;
 
{ TDDOptSurfaceDesc structure }
 
PDDOptSurfaceDesc = ^TDDOptSurfaceDesc;
TDDOptSurfaceDesc = record
dwSize: DWORD; // size of the DDOPTSURFACEDESC structure
dwFlags: DWORD; // determines what fields are valid
ddSCaps: TDDSCaps2; // Common caps like: Memory type
ddOSCaps: TDDOSCaps; // Common caps like: Memory type
guid: TGUID; // Compression technique GUID
dwCompressionRatio: DWORD; // Compression ratio
end;
 
DDOPTSURFACEDESC = TDDOptSurfaceDesc;
LPDDOPTSURFACEDESC = PDDOptSurfaceDesc;
 
{ TDDColorControl structure }
 
PDDColorControl = ^TDDColorControl;
TDDColorControl = record
dwSize: DWORD;
dwFlags: DWORD;
lBrightness: Longint;
lContrast: Longint;
lHue: Longint;
lSaturation: Longint;
lSharpness: Longint;
lGamma: Longint;
lColorEnable: Longint;
dwReserved1: DWORD;
end;
 
DDCOLORCONTROL = TDDColorControl;
LPDDCOLORCONTROL = PDDCOLORCONTROL;
 
{ TDDGammaRamp structure }
 
PDDGammaRamp = ^TDDGammaRamp;
TDDGammaRamp = packed record
red : array[0..255] of WORD;
green : array[0..255] of WORD;
blue : array[0..255] of WORD;
TDDGammaRamp = record
Red: array[0..255] of Word;
Green: array[0..255] of Word;
Blue: array[0..255] of Word;
end;
 
(*
* This is the structure within which DirectDraw returns data about the current graphics driver and chipset
*)
DDGAMMARAMP = TDDGammaRamp;
LPDDGAMMARAMP = PDDGammaRamp;
 
{ TDDDeviceIdentifier structure }
 
PDDDeviceIdentifier = ^TDDDeviceIdentifier;
TDDDeviceIdentifier = packed record
TDDDeviceIdentifier = record
//
// These elements are for presentation to the user only. They should not be used to identify particular
// drivers, since this is unreliable and many different strings may be associated with the same
702,8 → 876,13
guidDeviceIdentifier: TGUID;
end;
 
DDDEVICEIDENTIFIER = TDDDeviceIdentifier;
LPDDDEVICEIDENTIFIER = PDDDeviceIdentifier;
 
{ TDDDeviceIdentifier2 structure }
 
PDDDeviceIdentifier2 = ^TDDDeviceIdentifier2;
TDDDeviceIdentifier2 = packed record
TDDDeviceIdentifier2 = record
//
// These elements are for presentation to the user only. They should not be used to identify particular
// drivers, since this is unreliable and many different strings may be associated with the same
745,432 → 924,247
//
guidDeviceIdentifier: TGUID;
 
(*
* This element is used to determine the Windows Hardware Quality Lab (WHQL)
* certification level for this driver/device pair.
*)
//
// This element is used to determine the Windows Hardware Quality Lab (WHQL)
// certification level for this driver/device pair.
//
dwWHQLLevel: DWORD;
end;
 
(*
* callbacks
*)
DDDEVICEIDENTIFIER2 = TDDDeviceIdentifier2;
LPDDDEVICEIDENTIFIER2 = PDDDeviceIdentifier2;
 
{ Callbacks }
 
TClipperCallback = function(lpDDClipper: IDirectDrawClipper; hWnd: HWND;
Code: DWORD; lpContext: Pointer): HResult; stdcall;
LPCLIPPERCALLBACK = TClipperCallback;
 
TSurfacesStreamingCallback = function(Arg: DWORD): HResult; stdcall;
LPSURFACESTREAMINGCALLBACK =TSurfacesStreamingCallback;
 
(*
* TDDSurfaceDesc
*)
PDDSurfaceDesc_DX5 = ^TDDSurfaceDesc_DX5;
TDDSurfaceDesc_DX5 = packed record
dwSize: DWORD; // size of the TDDSurfaceDesc structure
dwFlags: DWORD; // determines what fields are valid
dwHeight: DWORD; // height of surface to be created
dwWidth: DWORD; // width of input surface
case Integer of
0: (
dwLinearSize : DWORD; // unused at the moment
);
1: (
lPitch: LongInt; // distance to start of next line (return value only)
dwBackBufferCount: DWORD; // number of back buffers requested
case Integer of
0: (
dwMipMapCount: DWORD; // number of mip-map levels requested
dwAlphaBitDepth: DWORD; // depth of alpha buffer requested
dwReserved: DWORD; // reserved
lpSurface: Pointer; // pointer to the associated surface memory
ddckCKDestOverlay: TDDColorKey; // color key for destination overlay use
ddckCKDestBlt: TDDColorKey; // color key for destination blt use
ddckCKSrcOverlay: TDDColorKey; // color key for source overlay use
ddckCKSrcBlt: TDDColorKey; // color key for source blt use
ddpfPixelFormat: TDDPixelFormat_DX5; // pixel format description of the surface
ddsCaps: TDDSCaps; // direct draw surface capabilities
);
1: (
dwZBufferBitDepth: DWORD; // depth of Z buffer requested
);
2: (
dwRefreshRate: DWORD; // refresh rate (used when display mode is described)
);
);
end;
 
PDDSurfaceDesc_DX6 = ^TDDSurfaceDesc_DX6;
TDDSurfaceDesc_DX6 = packed record
dwSize: DWORD; // size of the TDDSurfaceDesc structure
dwFlags: DWORD; // determines what fields are valid
dwHeight: DWORD; // height of surface to be created
dwWidth: DWORD; // width of input surface
case Integer of
0: (
dwLinearSize : DWORD; // unused at the moment
);
1: (
lPitch: LongInt; // distance to start of next line (return value only)
dwBackBufferCount: DWORD; // number of back buffers requested
case Integer of
0: (
dwMipMapCount: DWORD; // number of mip-map levels requested
dwAlphaBitDepth: DWORD; // depth of alpha buffer requested
dwReserved: DWORD; // reserved
lpSurface: Pointer; // pointer to the associated surface memory
ddckCKDestOverlay: TDDColorKey; // color key for destination overlay use
ddckCKDestBlt: TDDColorKey; // color key for destination blt use
ddckCKSrcOverlay: TDDColorKey; // color key for source overlay use
ddckCKSrcBlt: TDDColorKey; // color key for source blt use
ddpfPixelFormat: TDDPixelFormat_DX6; // pixel format description of the surface
ddsCaps: TDDSCaps; // direct draw surface capabilities
);
1: (
dwZBufferBitDepth: DWORD; // depth of Z buffer requested
);
2: (
dwRefreshRate: DWORD; // refresh rate (used when display mode is described)
);
);
end;
 
PDDSurfaceDesc = ^TDDSurfaceDesc;
{$IFDEF DIRECTX5}
TDDSurfaceDesc = TDDSurfaceDesc_DX5;
{$ELSE}
TDDSurfaceDesc = TDDSurfaceDesc_DX6;
{$ENDIF}
 
 
(*
* TDDSurfaceDesc2
*)
PDDSurfaceDesc2 = ^TDDSurfaceDesc2;
TDDSurfaceDesc2 = packed record
dwSize: DWORD; // size of the TDDSurfaceDesc structure
dwFlags: DWORD; // determines what fields are valid
dwHeight: DWORD; // height of surface to be created
dwWidth: DWORD; // width of input surface
case Integer of
0: (
lPitch : LongInt; // distance to start of next line (return value only)
);
1: (
dwLinearSize : DWORD; // Formless late-allocated optimized surface size
dwBackBufferCount: DWORD; // number of back buffers requested
case Integer of
0: (
dwMipMapCount: DWORD; // number of mip-map levels requested
dwAlphaBitDepth: DWORD; // depth of alpha buffer requested
dwReserved: DWORD; // reserved
lpSurface: Pointer; // pointer to the associated surface memory
ddckCKDestOverlay: TDDColorKey; // color key for destination overlay use
ddckCKDestBlt: TDDColorKey; // color key for destination blt use
ddckCKSrcOverlay: TDDColorKey; // color key for source overlay use
ddckCKSrcBlt: TDDColorKey; // color key for source blt use
ddpfPixelFormat: TDDPixelFormat; // pixel format description of the surface
ddsCaps: TDDSCaps2; // direct draw surface capabilities
dwTextureStage: DWORD; // stage in multitexture cascade
);
1: (
dwRefreshRate: DWORD; // refresh rate (used when display mode is described)
);
);
end;
 
(*
* TDDOptSurfaceDesc
*)
 
PDDOptSurfaceDesc = ^TDDOptSurfaceDesc;
TDDOptSurfaceDesc = packed record
dwSize : DWORD; // size of the DDOPTSURFACEDESC structure
dwFlags : DWORD; // determines what fields are valid
ddSCaps : TDDSCaps2; // Common caps like: Memory type
ddOSCaps : TDDOSCaps; // Common caps like: Memory type
guid : TGUID; // Compression technique GUID
dwCompressionRatio : DWORD; // Compression ratio
end;
 
(*
* DDCOLORCONTROL
*)
PDDColorControl = ^TDDColorControl;
TDDColorControl = packed record
dwSize: DWORD;
dwFlags: DWORD;
lBrightness: LongInt;
lContrast: LongInt;
lHue: LongInt;
lSaturation: LongInt;
lSharpness: LongInt;
lGamma: LongInt;
lColorEnable: LongInt;
dwReserved1: DWORD;
end;
 
(*
* callbacks
*)
 
{$IFNDEF WINNT}
TDDEnumModesCallback = function (const lpDDSurfaceDesc: TDDSurfaceDesc;
lpContext: Pointer) : HResult; stdcall;
LPDDENUMMODESCALLBACK = TDDEnumModesCallback;
 
TDDEnumModesCallback2 = function (const lpDDSurfaceDesc: TDDSurfaceDesc2;
lpContext: Pointer) : HResult; stdcall;
LPDDENUMMODESCALLBACK2 = TDDEnumModesCallback2;
 
TDDEnumSurfacesCallback = function (lpDDSurface: IDirectDrawSurface;
const lpDDSurfaceDesc: TDDSurfaceDesc; lpContext: Pointer) : HResult; stdcall;
LPDDENUMSURFACESCALLBACK = TDDEnumSurfacesCallback;
 
TDDEnumSurfacesCallback2 = function (lpDDSurface: IDirectDrawSurface4;
const lpDDSurfaceDesc: TDDSurfaceDesc2; lpContext: Pointer) : HResult; stdcall;
LPDDENUMSURFACESCALLBACK2 = TDDEnumSurfacesCallback2;
 
TDDEnumSurfacesCallback7 = function (lpDDSurface: IDirectDrawSurface7;
const lpDDSurfaceDesc: TDDSurfaceDesc2; lpContext: Pointer) : HResult; stdcall;
{$ENDIF}
LPDDENUMSURFACESCALLBACK7 = TDDEnumSurfacesCallback7;
 
(*
* INTERACES FOLLOW:
* IDirectDraw
* IDirectDrawClipper
* IDirectDrawPalette
* IDirectDrawSurface
*)
{ IDirectDraw Interface }
 
(*
* IDirectDraw
*)
 
IDirectDraw = interface (IUnknown)
['{6C14DB80-A733-11CE-A521-0020AF0BE560}']
(*** IDirectDraw methods ***)
// IDirectDraw methods
function Compact: HResult; stdcall;
function CreateClipper (dwFlags: DWORD;
out lplpDDClipper: IDirectDrawClipper;
function CreateClipper(dwFlags: DWORD; out lplpDDClipper: IDirectDrawClipper;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette (dwFlags: DWORD; lpColorTable: pointer;
out lplpDDPalette: IDirectDrawPalette;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreateSurface (var lpDDSurfaceDesc: TDDSurfaceDesc;
out lplpDDSurface: IDirectDrawSurface;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette(dwFlags: DWORD; lpColorTable: PPaletteEntry;
out lplpDDPalette: IDirectDrawPalette; pUnkOuter: IUnknown): HResult; stdcall;
function CreateSurface(const lpDDSurfaceDesc: TDDSurfaceDesc;
out lplpDDSurface: IDirectDrawSurface; pUnkOuter: IUnknown): HResult; stdcall;
function DuplicateSurface (lpDDSurface: IDirectDrawSurface;
out lplpDupDDSurface: IDirectDrawSurface) : HResult; stdcall;
function EnumDisplayModes (dwFlags: DWORD;
lpDDSurfaceDesc: PDDSurfaceDesc; lpContext: Pointer;
const lpDDSurfaceDesc: TDDSurfaceDesc; lpContext: Pointer;
lpEnumModesCallback: TDDEnumModesCallback) : HResult; stdcall;
function EnumSurfaces (dwFlags: DWORD; const lpDDSD: TDDSurfaceDesc;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback) :
HResult; stdcall;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback): HResult; stdcall;
function FlipToGDISurface: HResult; stdcall;
function GetCaps (lpDDDriverCaps: PDDCaps; lpDDHELCaps: PDDCaps) : HResult; stdcall;
function GetDisplayMode (out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function GetFourCCCodes (var lpNumCodes: DWORD; lpCodes: PDWORD) : HResult; stdcall;
function GetGDISurface (out lplpGDIDDSSurface: IDirectDrawSurface) :
HResult; stdcall;
function GetMonitorFrequency (out lpdwFrequency: DWORD) : HResult; stdcall;
function GetScanLine (out lpdwScanLine: DWORD) : HResult; stdcall;
function GetVerticalBlankStatus (out lpbIsInVB: BOOL) : HResult; stdcall;
function GetCaps(var lpDDDriverCaps: TDDCaps; var lpDDHELCaps: TDDCaps): HResult; stdcall;
function GetDisplayMode(var lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function GetFourCCCodes(var lpNumCodes, lpCodes: DWORD): HResult; stdcall;
function GetGDISurface(out lplpGDIDDSSurface: IDirectDrawSurface): HResult; stdcall;
function GetMonitorFrequency(var lpdwFrequency: DWORD): HResult; stdcall;
function GetScanLine(var lpdwScanLine: DWORD): HResult; stdcall;
function GetVerticalBlankStatus(var lpbIsInVB: BOOL): HResult; stdcall;
function Initialize (lpGUID: PGUID) : HResult; stdcall;
function RestoreDisplayMode: HResult; stdcall;
function SetCooperativeLevel (hWnd: HWND; dwFlags: DWORD) : HResult; stdcall;
(*** Warning! SetDisplayMode differs between DirectDraw 1 and DirectDraw 2 ***)
function SetDisplayMode (dwWidth: DWORD; dwHeight: DWORD;
dwBpp: DWORD) : HResult; stdcall;
function WaitForVerticalBlank (dwFlags: DWORD; hEvent: THandle) :
HResult; stdcall;
function SetDisplayMode(dwWidth, dwHeight, dwBpp: DWORD): HResult; stdcall;
function WaitForVerticalBlank(dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
end;
 
{ IDirectDraw2 Interface }
 
IDirectDraw2 = interface (IUnknown)
['{B3A6F3E0-2B43-11CF-A2DE-00AA00B93356}']
(*** IDirectDraw methods ***)
// IDirectDraw methods
function Compact: HResult; stdcall;
function CreateClipper (dwFlags: DWORD;
out lplpDDClipper: IDirectDrawClipper;
function CreateClipper(dwFlags: DWORD; out lplpDDClipper: IDirectDrawClipper;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette (dwFlags: DWORD; lpColorTable: pointer;
out lplpDDPalette: IDirectDrawPalette;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreateSurface (var lpDDSurfaceDesc: TDDSurfaceDesc;
out lplpDDSurface: IDirectDrawSurface;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette(dwFlags: DWORD; lpColorTable: PPaletteEntry;
out lplpDDPalette: IDirectDrawPalette; pUnkOuter: IUnknown): HResult; stdcall;
function CreateSurface(const lpDDSurfaceDesc: TDDSurfaceDesc;
out lplpDDSurface: IDirectDrawSurface; pUnkOuter: IUnknown): HResult; stdcall;
function DuplicateSurface (lpDDSurface: IDirectDrawSurface;
out lplpDupDDSurface: IDirectDrawSurface) : HResult; stdcall;
function EnumDisplayModes (dwFlags: DWORD;
lpDDSurfaceDesc: PDDSurfaceDesc; lpContext: Pointer;
const lpDDSurfaceDesc: TDDSurfaceDesc; lpContext: Pointer;
lpEnumModesCallback: TDDEnumModesCallback) : HResult; stdcall;
function EnumSurfaces (dwFlags: DWORD; var lpDDSD: TDDSurfaceDesc;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback) :
HResult; stdcall;
function EnumSurfaces(dwFlags: DWORD; const lpDDSD: TDDSurfaceDesc;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback): HResult; stdcall;
function FlipToGDISurface: HResult; stdcall;
function GetCaps (lpDDDriverCaps: PDDCaps; lpDDHELCaps: PDDCaps) : HResult; stdcall;
function GetDisplayMode (out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function GetFourCCCodes (var lpNumCodes: DWORD; lpCodes: PDWORD) : HResult; stdcall;
function GetCaps(var lpDDDriverCaps: TDDCaps; var lpDDHELCaps: TDDCaps): HResult; stdcall;
function GetDisplayMode(var lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function GetFourCCCodes(var lpNumCodes, lpCodes: DWORD): HResult; stdcall;
function GetGDISurface (out lplpGDIDDSSurface: IDirectDrawSurface) : HResult; stdcall;
function GetMonitorFrequency (out lpdwFrequency: DWORD) : HResult; stdcall;
function GetScanLine (out lpdwScanLine: DWORD) : HResult; stdcall;
function GetVerticalBlankStatus (out lpbIsInVB: BOOL) : HResult; stdcall;
function GetMonitorFrequency(var lpdwFrequency: DWORD): HResult; stdcall;
function GetScanLine(var lpdwScanLine: DWORD): HResult; stdcall;
function GetVerticalBlankStatus(var lpbIsInVB: BOOL): HResult; stdcall;
function Initialize (lpGUID: PGUID) : HResult; stdcall;
function RestoreDisplayMode: HResult; stdcall;
function SetCooperativeLevel (hWnd: HWND; dwFlags: DWORD) : HResult; stdcall;
(*** Warning! SetDisplayMode differs between DirectDraw 1 and DirectDraw 2 ***)
function SetDisplayMode (dwWidth: DWORD; dwHeight: DWORD; dwBPP: DWORD;
dwRefreshRate: DWORD; dwFlags: DWORD) : HResult; stdcall;
function WaitForVerticalBlank (dwFlags: DWORD; hEvent: THandle) :
HResult; stdcall;
(*** Added in the v2 interface ***)
function SetDisplayMode(dwWidth, dwHeight, dwBPP, dwRefreshRate: DWORD;
dwFlags: DWORD): HResult; stdcall;
function WaitForVerticalBlank(dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
// IDirectDraw2 methods
function GetAvailableVidMem (var lpDDSCaps: TDDSCaps;
out lpdwTotal, lpdwFree: DWORD) : HResult; stdcall;
var lpdwTotal, lpdwFree: DWORD): HResult; stdcall;
end;
 
{ IDirectDraw4 Interface }
 
IDirectDraw4 = interface (IUnknown)
['{9c59509a-39bd-11d1-8c4a-00c04fd930c5}']
(*** IDirectDraw methods ***)
['{9C59509A-39BD-11D1-8C4A-00C04FD930C5}']
// IDirectDraw methods
function Compact: HResult; stdcall;
function CreateClipper (dwFlags: DWORD;
out lplpDDClipper: IDirectDrawClipper;
function CreateClipper(dwFlags: DWORD; out lplpDDClipper: IDirectDrawClipper;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette (dwFlags: DWORD; lpColorTable: pointer;
out lplpDDPalette: IDirectDrawPalette;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette(dwFlags: DWORD; lpColorTable: PPaletteEntry;
out lplpDDPalette: IDirectDrawPalette; pUnkOuter: IUnknown): HResult; stdcall;
function CreateSurface (const lpDDSurfaceDesc: TDDSurfaceDesc2;
out lplpDDSurface: IDirectDrawSurface4;
pUnkOuter: IUnknown) : HResult; stdcall;
out lplpDDSurface: IDirectDrawSurface4; pUnkOuter: IUnknown): HResult; stdcall;
function DuplicateSurface (lpDDSurface: IDirectDrawSurface4;
out lplpDupDDSurface: IDirectDrawSurface4) : HResult; stdcall;
function EnumDisplayModes (dwFlags: DWORD;
lpDDSurfaceDesc: PDDSurfaceDesc2; lpContext: Pointer;
const lpDDSurfaceDesc: TDDSurfaceDesc2; lpContext: Pointer;
lpEnumModesCallback: TDDEnumModesCallback2) : HResult; stdcall;
function EnumSurfaces (dwFlags: DWORD; const lpDDSD: TDDSurfaceDesc2;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback2) :
HResult; stdcall;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback2): HResult; stdcall;
function FlipToGDISurface: HResult; stdcall;
function GetCaps (lpDDDriverCaps: PDDCaps; lpDDHELCaps: PDDCaps) : HResult; stdcall;
function GetDisplayMode (out lpDDSurfaceDesc: TDDSurfaceDesc2) : HResult; stdcall;
function GetFourCCCodes (var lpNumCodes: DWORD; lpCodes: PDWORD) : HResult; stdcall;
function GetGDISurface (out lplpGDIDDSSurface: IDirectDrawSurface4) :
HResult; stdcall;
function GetMonitorFrequency (out lpdwFrequency: DWORD) : HResult; stdcall;
function GetScanLine (out lpdwScanLine: DWORD) : HResult; stdcall;
function GetVerticalBlankStatus (out lpbIsInVB: BOOL) : HResult; stdcall;
function GetCaps(var lpDDDriverCaps: TDDCaps; var lpDDHELCaps: TDDCaps): HResult; stdcall;
function GetDisplayMode(var lpDDSurfaceDesc: TDDSurfaceDesc2): HResult; stdcall;
function GetFourCCCodes(var lpNumCodes, lpCodes: DWORD): HResult; stdcall;
function GetGDISurface(out lplpGDIDDSSurface: IDirectDrawSurface2): HResult; stdcall;
function GetMonitorFrequency(var lpdwFrequency: DWORD): HResult; stdcall;
function GetScanLine(var lpdwScanLine: DWORD): HResult; stdcall;
function GetVerticalBlankStatus(var lpbIsInVB: BOOL): HResult; stdcall;
function Initialize (lpGUID: PGUID) : HResult; stdcall;
function RestoreDisplayMode: HResult; stdcall;
function SetCooperativeLevel (hWnd: HWND; dwFlags: DWORD) : HResult; stdcall;
(*** Warning! SetDisplayMode differs between DirectDraw 1 and DirectDraw 2 ***)
function SetDisplayMode (dwWidth: DWORD; dwHeight: DWORD; dwBPP: DWORD;
dwRefreshRate: DWORD; dwFlags: DWORD) : HResult; stdcall;
function WaitForVerticalBlank (dwFlags: DWORD; hEvent: THandle) :
HResult; stdcall;
(*** Added in the v2 interface ***)
function GetAvailableVidMem (const lpDDSCaps: TDDSCaps2;
out lpdwTotal, lpdwFree: DWORD) : HResult; stdcall;
(*** Added in the V4 Interface ***)
function GetSurfaceFromDC (hdc : Windows.HDC;
out lpDDS4: IDirectDrawSurface4) : HResult; stdcall;
function SetDisplayMode(dwWidth, dwHeight, dwBPP, dwRefreshRate: DWORD;
dwFlags: DWORD): HResult; stdcall;
function WaitForVerticalBlank(dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
// IDirectDraw2 methods
function GetAvailableVidMem(var lpDDSCaps: TDDSCaps;
var lpdwTotal, lpdwFree: DWORD): HResult; stdcall;
// IDirectDraw4 methods
function GetSurfaceFromDC(hdc: HDC; lpDDS: IDirectDrawSurface4): HResult; stdcall;
function RestoreAllSurfaces : HResult; stdcall;
function TestCooperativeLevel : HResult; stdcall;
function GetDeviceIdentifier (out lpdddi: TDDDeviceIdentifier;
dwFlags: DWORD) : HResult; stdcall;
function GetDeviceIdentifier(var lpdddi: TDDDeviceIdentifier; dwFlags: DWORD): HResult; stdcall;
end;
 
{ IDirectDraw7 Interface }
 
IDirectDraw7 = interface (IUnknown)
['{15e65ec0-3b9c-11d2-b92f-00609797ea5b}']
(*** IDirectDraw methods ***)
['{15E65EC0-3B9C-11D2-B92F-00609797EA5B}']
// IDirectDraw methods
function Compact: HResult; stdcall;
function CreateClipper (dwFlags: DWORD;
out lplpDDClipper: IDirectDrawClipper;
function CreateClipper(dwFlags: DWORD; out lplpDDClipper: IDirectDrawClipper;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette (dwFlags: DWORD; lpColorTable: pointer;
out lplpDDPalette: IDirectDrawPalette;
pUnkOuter: IUnknown) : HResult; stdcall;
function CreatePalette(dwFlags: DWORD; lpColorTable: PPaletteEntry;
out lplpDDPalette: IDirectDrawPalette; pUnkOuter: IUnknown): HResult; stdcall;
function CreateSurface (const lpDDSurfaceDesc: TDDSurfaceDesc2;
out lplpDDSurface: IDirectDrawSurface7;
pUnkOuter: IUnknown) : HResult; stdcall;
out lplpDDSurface: IDirectDrawSurface7; pUnkOuter: IUnknown): HResult; stdcall;
function DuplicateSurface (lpDDSurface: IDirectDrawSurface7;
out lplpDupDDSurface: IDirectDrawSurface7) : HResult; stdcall;
function EnumDisplayModes (dwFlags: DWORD;
lpDDSurfaceDesc: PDDSurfaceDesc2; lpContext: Pointer;
const lpDDSurfaceDesc: TDDSurfaceDesc2; lpContext: Pointer;
lpEnumModesCallback: TDDEnumModesCallback2) : HResult; stdcall;
function EnumSurfaces (dwFlags: DWORD; const lpDDSD: TDDSurfaceDesc2;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback7) :
HResult; stdcall;
lpContext: Pointer; lpEnumCallback: TDDEnumSurfacesCallback7): HResult; stdcall;
function FlipToGDISurface: HResult; stdcall;
function GetCaps (lpDDDriverCaps: PDDCaps; lpDDHELCaps: PDDCaps) : HResult; stdcall;
function GetDisplayMode (out lpDDSurfaceDesc: TDDSurfaceDesc2) : HResult; stdcall;
function GetFourCCCodes (var lpNumCodes: DWORD; lpCodes: PDWORD) : HResult; stdcall;
function GetGDISurface (out lplpGDIDDSSurface: IDirectDrawSurface7) :
HResult; stdcall;
function GetMonitorFrequency (out lpdwFrequency: DWORD) : HResult; stdcall;
function GetScanLine (out lpdwScanLine: DWORD) : HResult; stdcall;
function GetVerticalBlankStatus (out lpbIsInVB: BOOL) : HResult; stdcall;
function GetCaps(var lpDDDriverCaps: TDDCaps; var lpDDHELCaps: TDDCaps): HResult; stdcall;
function GetDisplayMode(var lpDDSurfaceDesc: TDDSurfaceDesc2): HResult; stdcall;
function GetFourCCCodes(var lpNumCodes, lpCodes: DWORD): HResult; stdcall;
function GetGDISurface(out lplpGDIDDSSurface: IDirectDrawSurface7): HResult; stdcall;
function GetMonitorFrequency(var lpdwFrequency: DWORD): HResult; stdcall;
function GetScanLine(var lpdwScanLine: DWORD): HResult; stdcall;
function GetVerticalBlankStatus(var lpbIsInVB: BOOL): HResult; stdcall;
function Initialize (lpGUID: PGUID) : HResult; stdcall;
function RestoreDisplayMode: HResult; stdcall;
function SetCooperativeLevel (hWnd: HWND; dwFlags: DWORD) : HResult; stdcall;
function SetDisplayMode (dwWidth: DWORD; dwHeight: DWORD; dwBPP: DWORD;
dwRefreshRate: DWORD; dwFlags: DWORD) : HResult; stdcall;
function WaitForVerticalBlank (dwFlags: DWORD; hEvent: THandle) :
HResult; stdcall;
(*** Added in the v2 interface ***)
function GetAvailableVidMem (const lpDDSCaps: TDDSCaps2;
out lpdwTotal, lpdwFree: DWORD) : HResult; stdcall;
(*** Added in the V4 Interface ***)
function GetSurfaceFromDC (hdc : Windows.HDC;
out lpDDS: IDirectDrawSurface7) : HResult; stdcall;
function SetDisplayMode(dwWidth, dwHeight, dwBPP, dwRefreshRate: DWORD;
dwFlags: DWORD): HResult; stdcall;
function WaitForVerticalBlank(dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
// IDirectDraw2 methods
function GetAvailableVidMem(var lpDDSCaps: TDDSCaps;
var lpdwTotal, lpdwFree: DWORD): HResult; stdcall;
// IDirectDraw4 methods
function GetSurfaceFromDC(hdc: HDC; lpDDS: IDirectDrawSurface4): HResult; stdcall;
function RestoreAllSurfaces : HResult; stdcall;
function TestCooperativeLevel : HResult; stdcall;
function GetDeviceIdentifier (out lpdddi: TDDDeviceIdentifier2;
dwFlags: DWORD) : HResult; stdcall;
function StartModeTest(const lpModesToTest; dwNumEntries, dwFlags: DWORD) : HResult; stdcall;
function EvaluateMode(dwFlags: DWORD; out pSecondsUntilTimeout: DWORD) : HResult; stdcall;
function GetDeviceIdentifier(var lpdddi: TDDDeviceIdentifier; dwFlags: DWORD): HResult; stdcall;
// IDirectDraw7 methods
function StartModeTest(var lpModesToTest: TSize; dwNumEntries: DWORD; dwFlags: DWORD): HResult; stdcall;
function EvaluateMode(dwFlags: DWORD; var pSecondsUntilTimeout: DWORD): HResult; stdcall;
end;
 
{ IDirectDrawPalette Interface }
 
 
(*
* IDirectDrawPalette
*)
 
IDirectDrawPalette = interface (IUnknown)
['{6C14DB84-A733-11CE-A521-0020AF0BE560}']
(*** IDirectDrawPalette methods ***)
function GetCaps (out lpdwCaps: DWORD) : HResult; stdcall;
// IDirectDrawPalette methods
function GetCaps(varlpdwCaps: DWORD): HResult; stdcall;
function GetEntries (dwFlags: DWORD; dwBase: DWORD; dwNumEntries: DWORD;
lpEntries: pointer) : HResult; stdcall;
lpEntries: PPaletteEntry): HResult; stdcall;
function Initialize (lpDD: IDirectDraw; dwFlags: DWORD;
lpDDColorTable: pointer) : HResult; stdcall;
lpDDColorTable: PPaletteEntry): HResult; stdcall;
function SetEntries (dwFlags: DWORD; dwStartingEntry: DWORD;
dwCount: DWORD; lpEntries: pointer) : HResult; stdcall;
dwCount: DWORD; lpEntries: PPaletteEntry): HResult; stdcall;
end;
 
(*
* IDirectDrawClipper
*)
{ IDirectDrawClipper Interface }
 
IDirectDrawClipper = interface (IUnknown)
['{6C14DB85-A733-11CE-A521-0020AF0BE560}']
(*** IDirectDrawClipper methods ***)
function GetClipList (lpRect: PRect; lpClipList: PRgnData;
// IDirectDrawClipper methods
function GetClipList(const lpRect: TRect; lpClipList: PRgnData;
var lpdwSize: DWORD) : HResult; stdcall;
function GetHWnd (out lphWnd: HWND) : HResult; stdcall;
function GetHWnd(var lphWnd: HWND): HResult; stdcall;
function Initialize (lpDD: IDirectDraw; dwFlags: DWORD) : HResult; stdcall;
function IsClipListChanged (out lpbChanged: BOOL) : HResult; stdcall;
function IsClipListChanged(var lpbChanged: BOOL): HResult; stdcall;
function SetClipList (lpClipList: PRgnData; dwFlags: DWORD) : HResult; stdcall;
function SetHWnd (dwFlags: DWORD; hWnd: HWND) : HResult; stdcall;
end;
 
(*
* IDirectDrawSurface and related interfaces
*)
{ IDirectDrawSurface Interface }
 
IDirectDrawSurface = interface (IUnknown)
['{6C14DB81-A733-11CE-A521-0020AF0BE560}']
(*** IDirectDrawSurface methods ***)
function AddAttachedSurface (lpDDSAttachedSurface: IDirectDrawSurface) :
HResult; stdcall;
// IDirectDrawSurface methods
function AddAttachedSurface(lpDDSAttachedSurface: IDirectDrawSurface): HResult; stdcall;
function AddOverlayDirtyRect (const lpRect: TRect) : HResult; stdcall;
function Blt (lpDestRect: PRect;
lpDDSrcSurface: IDirectDrawSurface; lpSrcRect: PRect;
dwFlags: DWORD; lpDDBltFx: PDDBltFX) : HResult; stdcall;
function Blt(const lpDestRect: TRect; lpDDSrcSurface: IDirectDrawSurface;
const lpSrcRect: TRect; dwFlags: DWORD; const lpDDBltFx: TDDBltFX): HResult; stdcall;
function BltBatch (const lpDDBltBatch: TDDBltBatch; dwCount: DWORD;
dwFlags: DWORD) : HResult; stdcall;
function BltFast (dwX: DWORD; dwY: DWORD;
lpDDSrcSurface: IDirectDrawSurface; lpSrcRect: PRect;
dwTrans: DWORD) : HResult; stdcall;
function BltFast(dwX, dwY: DWORD; lpDDSrcSurface: IDirectDrawSurface;
const lpSrcRect: TRect; dwTrans: DWORD): HResult; stdcall;
function DeleteAttachedSurface (dwFlags: DWORD;
lpDDSAttachedSurface: IDirectDrawSurface) : HResult; stdcall;
function EnumAttachedSurfaces (lpContext: Pointer;
1180,57 → 1174,50
function Flip (lpDDSurfaceTargetOverride: IDirectDrawSurface;
dwFlags: DWORD) : HResult; stdcall;
function GetAttachedSurface (var lpDDSCaps: TDDSCaps;
(*out*)var lplpDDAttachedSurface: IDirectDrawSurface) : HResult; stdcall;
out lplpDDAttachedSurface: IDirectDrawSurface): HResult; stdcall;
function GetBltStatus (dwFlags: DWORD) : HResult; stdcall;
function GetCaps (out lpDDSCaps: TDDSCaps) : HResult; stdcall;
function GetCaps(var lpDDSCaps: TDDSCaps): HResult; stdcall;
function GetClipper (out lplpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function GetColorKey (dwFlags: DWORD; out lpDDColorKey: TDDColorKey) :
HResult; stdcall;
function GetDC (out lphDC: HDC) : HResult; stdcall;
function GetColorKey(dwFlags: DWORD; var lpDDColorKey: TDDColorKey): HResult; stdcall;
function GetDC(var lphDC: HDC): HResult; stdcall;
function GetFlipStatus (dwFlags: DWORD) : HResult; stdcall;
function GetOverlayPosition (out lplX, lplY: LongInt) : HResult; stdcall;
function GetOverlayPosition(var lplX, lplY: Longint): HResult; stdcall;
function GetPalette (out lplpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function GetPixelFormat (out lpDDPixelFormat: TDDPixelFormat) : HResult; stdcall;
function GetSurfaceDesc (out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function GetPixelFormat(var lpDDPixelFormat: TDDPixelFormat): HResult; stdcall;
function GetSurfaceDesc(var lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function Initialize (lpDD: IDirectDraw;
out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
const lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function IsLost: HResult; stdcall;
function Lock (lpDestRect: PRect; out lpDDSurfaceDesc:
TDDSurfaceDesc; dwFlags: DWORD; hEvent: THandle) : HResult; stdcall;
function ReleaseDC (hDC: Windows.HDC) : HResult; stdcall;
function _Restore: HResult; stdcall;
function Lock(lpDestRect: PRect; var lpDDSurfaceDesc: TDDSurfaceDesc;
dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
function ReleaseDC(hDC: HDC): HResult; stdcall;
function Restore: HResult; stdcall;
function SetClipper (lpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function SetColorKey (dwFlags: DWORD; lpDDColorKey: PDDColorKey) :
HResult; stdcall;
function SetOverlayPosition (lX, lY: LongInt) : HResult; stdcall;
function SetColorKey(dwFlags: DWORD; const lpDDColorKey: TDDColorKey): HResult; stdcall;
function SetOverlayPosition(lX, lY: Longint): HResult; stdcall;
function SetPalette (lpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function Unlock (lpSurfaceData: Pointer) : HResult; stdcall;
function UpdateOverlay (lpSrcRect: PRect;
lpDDDestSurface: IDirectDrawSurface; lpDestRect: PRect;
dwFlags: DWORD; lpDDOverlayFx: PDDOverlayFX) : HResult; stdcall;
function UpdateOverlay(const lpSrcRect: TRect;
lpDDDestSurface: IDirectDrawSurface; const lpDestRect: TRect;
dwFlags: DWORD; const lpDDOverlayFx: TDDOverlayFX): HResult; stdcall;
function UpdateOverlayDisplay (dwFlags: DWORD) : HResult; stdcall;
function UpdateOverlayZOrder (dwFlags: DWORD;
lpDDSReference: IDirectDrawSurface) : HResult; stdcall;
end;
 
(*
* IDirectDrawSurface2 and related interfaces
*)
{ IDirectDrawSurface2 Interface }
 
IDirectDrawSurface2 = interface (IUnknown)
['{57805885-6eec-11cf-9441-a82303c10e27}']
(*** IDirectDrawSurface methods ***)
function AddAttachedSurface (lpDDSAttachedSurface: IDirectDrawSurface2) :
HResult; stdcall;
['{57805885-6EEC-11CF-9441-A82303C10E27}']
// IDirectDrawSurface methods
function AddAttachedSurface(lpDDSAttachedSurface: IDirectDrawSurface2): HResult; stdcall;
function AddOverlayDirtyRect (const lpRect: TRect) : HResult; stdcall;
function Blt (lpDestRect: PRect;
lpDDSrcSurface: IDirectDrawSurface2; lpSrcRect: PRect;
dwFlags: DWORD; lpDDBltFx: PDDBltFX) : HResult; stdcall;
function Blt(const lpDestRect: TRect; lpDDSrcSurface: IDirectDrawSurface2;
const lpSrcRect: TRect; dwFlags: DWORD; const lpDDBltFx: TDDBltFX): HResult; stdcall;
function BltBatch (const lpDDBltBatch: TDDBltBatch; dwCount: DWORD;
dwFlags: DWORD) : HResult; stdcall;
function BltFast (dwX: DWORD; dwY: DWORD;
lpDDSrcSurface: IDirectDrawSurface2; lpSrcRect: PRect;
dwTrans: DWORD) : HResult; stdcall;
function BltFast(dwX, dwY: DWORD; lpDDSrcSurface: IDirectDrawSurface2;
const lpSrcRect: TRect; dwTrans: DWORD): HResult; stdcall;
function DeleteAttachedSurface (dwFlags: DWORD;
lpDDSAttachedSurface: IDirectDrawSurface2) : HResult; stdcall;
function EnumAttachedSurfaces (lpContext: Pointer;
1242,56 → 1229,51
function GetAttachedSurface (var lpDDSCaps: TDDSCaps;
out lplpDDAttachedSurface: IDirectDrawSurface2) : HResult; stdcall;
function GetBltStatus (dwFlags: DWORD) : HResult; stdcall;
function GetCaps (out lpDDSCaps: TDDSCaps) : HResult; stdcall;
function GetCaps(var lpDDSCaps: TDDSCaps): HResult; stdcall;
function GetClipper (out lplpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function GetColorKey (dwFlags: DWORD; out lpDDColorKey: TDDColorKey) :
HResult; stdcall;
function GetDC (out lphDC: HDC) : HResult; stdcall;
function GetColorKey(dwFlags: DWORD; var lpDDColorKey: TDDColorKey): HResult; stdcall;
function GetDC(var lphDC: HDC): HResult; stdcall;
function GetFlipStatus (dwFlags: DWORD) : HResult; stdcall;
function GetOverlayPosition (out lplX, lplY: LongInt) : HResult; stdcall;
function GetOverlayPosition(var lplX, lplY: Longint): HResult; stdcall;
function GetPalette (out lplpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function GetPixelFormat (out lpDDPixelFormat: TDDPixelFormat) : HResult; stdcall;
function GetSurfaceDesc (out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function Initialize (lpDD: IDirectDraw;
out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function GetPixelFormat(var lpDDPixelFormat: TDDPixelFormat): HResult; stdcall;
function GetSurfaceDesc(var lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function Initialize(lpDD: IDirectDraw; const lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function IsLost: HResult; stdcall;
function Lock (lpDestRect: PRect;
out lpDDSurfaceDesc: TDDSurfaceDesc; dwFlags: DWORD;
hEvent: THandle) : HResult; stdcall;
function ReleaseDC (hDC: Windows.HDC) : HResult; stdcall;
function _Restore: HResult; stdcall;
function Lock(lpDestRect: PRect; const lpDDSurfaceDesc: TDDSurfaceDesc;
dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
function ReleaseDC(hDC: HDC): HResult; stdcall;
function Restore: HResult; stdcall;
function SetClipper (lpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function SetColorKey (dwFlags: DWORD; lpDDColorKey: PDDColorKey) :
HResult; stdcall;
function SetOverlayPosition (lX, lY: LongInt) : HResult; stdcall;
function SetColorKey(dwFlags: DWORD; const lpDDColorKey: TDDColorKey): HResult; stdcall;
function SetOverlayPosition(lX, lY: Longint): HResult; stdcall;
function SetPalette (lpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function Unlock (lpSurfaceData: Pointer) : HResult; stdcall;
function UpdateOverlay (lpSrcRect: PRect;
lpDDDestSurface: IDirectDrawSurface2; lpDestRect: PRect;
dwFlags: DWORD; lpDDOverlayFx: PDDOverlayFX) : HResult; stdcall;
function UpdateOverlay(const lpSrcRect: TRect;
lpDDDestSurface: IDirectDrawSurface2; const lpDestRect: TRect;
dwFlags: DWORD; const lpDDOverlayFx: TDDOverlayFX): HResult; stdcall;
function UpdateOverlayDisplay (dwFlags: DWORD) : HResult; stdcall;
function UpdateOverlayZOrder (dwFlags: DWORD;
lpDDSReference: IDirectDrawSurface2) : HResult; stdcall;
(*** Added in the v2 interface ***)
function GetDDInterface (var lplpDD: IDirectDraw) : HResult; stdcall;
// IDirectDrawSurface2 methods
function GetDDInterface(out lplpDD: IUnknown): HResult; stdcall;
function PageLock (dwFlags: DWORD) : HResult; stdcall;
function PageUnlock (dwFlags: DWORD) : HResult; stdcall;
end;
 
{ IDirectDrawSurface3 Interface }
 
IDirectDrawSurface3 = interface (IUnknown)
['{DA044E00-69B2-11D0-A1D5-00AA00B8DFBB}']
(*** IDirectDrawSurface methods ***)
function AddAttachedSurface (lpDDSAttachedSurface: IDirectDrawSurface3) :
HResult; stdcall;
// IDirectDrawSurface methods
function AddAttachedSurface(lpDDSAttachedSurface: IDirectDrawSurface3): HResult; stdcall;
function AddOverlayDirtyRect (const lpRect: TRect) : HResult; stdcall;
function Blt (lpDestRect: PRect;
lpDDSrcSurface: IDirectDrawSurface3; lpSrcRect: PRect;
dwFlags: DWORD; lpDDBltFx: PDDBltFX) : HResult; stdcall;
function Blt(const lpDestRect: TRect; lpDDSrcSurface: IDirectDrawSurface3;
const lpSrcRect: TRect; dwFlags: DWORD; const lpDDBltFx: TDDBltFX): HResult; stdcall;
function BltBatch (const lpDDBltBatch: TDDBltBatch; dwCount: DWORD;
dwFlags: DWORD) : HResult; stdcall;
function BltFast (dwX: DWORD; dwY: DWORD;
lpDDSrcSurface: IDirectDrawSurface3; lpSrcRect: PRect;
dwTrans: DWORD) : HResult; stdcall;
function BltFast(dwX, dwY: DWORD; lpDDSrcSurface: IDirectDrawSurface3;
const lpSrcRect: TRect; dwTrans: DWORD): HResult; stdcall;
function DeleteAttachedSurface (dwFlags: DWORD;
lpDDSAttachedSurface: IDirectDrawSurface3) : HResult; stdcall;
function EnumAttachedSurfaces (lpContext: Pointer;
1303,61 → 1285,53
function GetAttachedSurface (var lpDDSCaps: TDDSCaps;
out lplpDDAttachedSurface: IDirectDrawSurface3) : HResult; stdcall;
function GetBltStatus (dwFlags: DWORD) : HResult; stdcall;
function GetCaps (out lpDDSCaps: TDDSCaps) : HResult; stdcall;
function GetCaps(var lpDDSCaps: TDDSCaps): HResult; stdcall;
function GetClipper (out lplpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function GetColorKey (dwFlags: DWORD; out lpDDColorKey: TDDColorKey) :
HResult; stdcall;
function GetDC (out lphDC: HDC) : HResult; stdcall;
function GetColorKey(dwFlags: DWORD; var lpDDColorKey: TDDColorKey): HResult; stdcall;
function GetDC(var lphDC: HDC): HResult; stdcall;
function GetFlipStatus (dwFlags: DWORD) : HResult; stdcall;
function GetOverlayPosition (out lplX, lplY: LongInt) : HResult; stdcall;
function GetOverlayPosition(var lplX, lplY: Longint): HResult; stdcall;
function GetPalette (out lplpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function GetPixelFormat (out lpDDPixelFormat: TDDPixelFormat) : HResult; stdcall;
function GetSurfaceDesc (out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function Initialize (lpDD: IDirectDraw;
out lpDDSurfaceDesc: TDDSurfaceDesc) : HResult; stdcall;
function GetPixelFormat(var lpDDPixelFormat: TDDPixelFormat): HResult; stdcall;
function GetSurfaceDesc(var lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function Initialize(lpDD: IDirectDraw; const lpDDSurfaceDesc: TDDSurfaceDesc): HResult; stdcall;
function IsLost: HResult; stdcall;
function Lock (lpDestRect: PRect;
out lpDDSurfaceDesc: TDDSurfaceDesc; dwFlags: DWORD;
hEvent: THandle) : HResult; stdcall;
function ReleaseDC (hDC: Windows.HDC) : HResult; stdcall;
function _Restore: HResult; stdcall;
function Lock(lpDestRect: PRect; const lpDDSurfaceDesc: TDDSurfaceDesc;
dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
function ReleaseDC(hDC: HDC): HResult; stdcall;
function Restore: HResult; stdcall;
function SetClipper (lpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function SetColorKey (dwFlags: DWORD; lpDDColorKey: PDDColorKey) :
HResult; stdcall;
function SetOverlayPosition (lX, lY: LongInt) : HResult; stdcall;
function SetColorKey(dwFlags: DWORD; const lpDDColorKey: TDDColorKey): HResult; stdcall;
function SetOverlayPosition(lX, lY: Longint): HResult; stdcall;
function SetPalette (lpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function Unlock (lpSurfaceData: Pointer) : HResult; stdcall;
function UpdateOverlay (lpSrcRect: PRect;
lpDDDestSurface: IDirectDrawSurface3; lpDestRect: PRect;
dwFlags: DWORD; lpDDOverlayFx: PDDOverlayFX) : HResult; stdcall;
function UpdateOverlay(const lpSrcRect: TRect;
lpDDDestSurface: IDirectDrawSurface3; const lpDestRect: TRect;
dwFlags: DWORD; const lpDDOverlayFx: TDDOverlayFX): HResult; stdcall;
function UpdateOverlayDisplay (dwFlags: DWORD) : HResult; stdcall;
function UpdateOverlayZOrder (dwFlags: DWORD;
lpDDSReference: IDirectDrawSurface3) : HResult; stdcall;
(*** Added in the v2 interface ***)
function GetDDInterface (out lplpDD: IDirectDraw) : HResult; stdcall;
// IDirectDrawSurface2 methods
function GetDDInterface(out lplpDD: IUnknown): HResult; stdcall;
function PageLock (dwFlags: DWORD) : HResult; stdcall;
function PageUnlock (dwFlags: DWORD) : HResult; stdcall;
(*** Added in the V3 interface ***)
// IDirectDrawSurface3 methods
function SetSurfaceDesc(const lpddsd: TDDSurfaceDesc; dwFlags: DWORD) : HResult; stdcall;
end;
 
(*
* IDirectDrawSurface4 and related interfaces
*)
{ IDirectDrawSurface4 Interface }
 
IDirectDrawSurface4 = interface (IUnknown)
['{0B2B8630-AD35-11D0-8EA6-00609797EA5B}']
(*** IDirectDrawSurface methods ***)
function AddAttachedSurface (lpDDSAttachedSurface: IDirectDrawSurface4) :
HResult; stdcall;
// IDirectDrawSurface methods
function AddAttachedSurface(lpDDSAttachedSurface: IDirectDrawSurface4): HResult; stdcall;
function AddOverlayDirtyRect (const lpRect: TRect) : HResult; stdcall;
function Blt (lpDestRect: PRect;
lpDDSrcSurface: IDirectDrawSurface4; lpSrcRect: PRect;
dwFlags: DWORD; lpDDBltFx: PDDBltFX) : HResult; stdcall;
function Blt(const lpDestRect: TRect; lpDDSrcSurface: IDirectDrawSurface4;
const lpSrcRect: TRect; dwFlags: DWORD; const lpDDBltFx: TDDBltFX): HResult; stdcall;
function BltBatch (const lpDDBltBatch: TDDBltBatch; dwCount: DWORD;
dwFlags: DWORD) : HResult; stdcall;
function BltFast (dwX: DWORD; dwY: DWORD;
lpDDSrcSurface: IDirectDrawSurface4; lpSrcRect: PRect;
dwTrans: DWORD) : HResult; stdcall;
function BltFast(dwX, dwY: DWORD; lpDDSrcSurface: IDirectDrawSurface4;
const lpSrcRect: TRect; dwTrans: DWORD): HResult; stdcall;
function DeleteAttachedSurface (dwFlags: DWORD;
lpDDSAttachedSurface: IDirectDrawSurface4) : HResult; stdcall;
function EnumAttachedSurfaces (lpContext: Pointer;
1366,69 → 1340,62
lpfnCallback: TDDEnumSurfacesCallback2) : HResult; stdcall;
function Flip (lpDDSurfaceTargetOverride: IDirectDrawSurface4;
dwFlags: DWORD) : HResult; stdcall;
function GetAttachedSurface (const lpDDSCaps: TDDSCaps2;
function GetAttachedSurface(var lpDDSCaps: TDDSCaps2;
out lplpDDAttachedSurface: IDirectDrawSurface4) : HResult; stdcall;
function GetBltStatus (dwFlags: DWORD) : HResult; stdcall;
function GetCaps (out lpDDSCaps: TDDSCaps2) : HResult; stdcall;
function GetCaps(var lpDDSCaps: TDDSCaps2): HResult; stdcall;
function GetClipper (out lplpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function GetColorKey (dwFlags: DWORD; out lpDDColorKey: TDDColorKey) :
HResult; stdcall;
function GetDC (out lphDC: HDC) : HResult; stdcall;
function GetColorKey(dwFlags: DWORD; var lpDDColorKey: TDDColorKey): HResult; stdcall;
function GetDC(var lphDC: HDC): HResult; stdcall;
function GetFlipStatus (dwFlags: DWORD) : HResult; stdcall;
function GetOverlayPosition (out lplX, lplY: LongInt) : HResult; stdcall;
function GetOverlayPosition(var lplX, lplY: Longint): HResult; stdcall;
function GetPalette (out lplpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function GetPixelFormat (out lpDDPixelFormat: TDDPixelFormat) : HResult; stdcall;
function GetSurfaceDesc (out lpDDSurfaceDesc: TDDSurfaceDesc2) : HResult; stdcall;
function Initialize (lpDD: IDirectDraw;
out lpDDSurfaceDesc: TDDSurfaceDesc2) : HResult; stdcall;
function GetPixelFormat(var lpDDPixelFormat: TDDPixelFormat): HResult; stdcall;
function GetSurfaceDesc(var lpDDSurfaceDesc: TDDSurfaceDesc2): HResult; stdcall;
function Initialize(lpDD: IDirectDraw; const lpDDSurfaceDesc: TDDSurfaceDesc2): HResult; stdcall;
function IsLost: HResult; stdcall;
function Lock (lpDestRect: PRect;
out lpDDSurfaceDesc: TDDSurfaceDesc2; dwFlags: DWORD;
hEvent: THandle) : HResult; stdcall;
function ReleaseDC (hDC: Windows.HDC) : HResult; stdcall;
function _Restore: HResult; stdcall;
function Lock(lpDestRect: PRect; const lpDDSurfaceDesc: TDDSurfaceDesc2;
dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
function ReleaseDC(hDC: HDC): HResult; stdcall;
function Restore: HResult; stdcall;
function SetClipper (lpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function SetColorKey (dwFlags: DWORD; lpDDColorKey: PDDColorKey) :
HResult; stdcall;
function SetOverlayPosition (lX, lY: LongInt) : HResult; stdcall;
function SetColorKey(dwFlags: DWORD; const lpDDColorKey: TDDColorKey): HResult; stdcall;
function SetOverlayPosition(lX, lY: Longint): HResult; stdcall;
function SetPalette (lpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function Unlock (lpRect: PRect) : HResult; stdcall;
function UpdateOverlay (lpSrcRect: PRect;
lpDDDestSurface: IDirectDrawSurface4; lpDestRect: PRect;
dwFlags: DWORD; lpDDOverlayFx: PDDOverlayFX) : HResult; stdcall;
function Unlock(lpSurfaceData: Pointer): HResult; stdcall;
function UpdateOverlay(const lpSrcRect: TRect; lpDDDestSurface: IDirectDrawSurface4;
const lpDestRect: TRect; dwFlags: DWORD; const lpDDOverlayFx: TDDOverlayFX): HResult; stdcall;
function UpdateOverlayDisplay (dwFlags: DWORD) : HResult; stdcall;
function UpdateOverlayZOrder (dwFlags: DWORD;
lpDDSReference: IDirectDrawSurface4) : HResult; stdcall;
(*** Added in the v2 interface ***)
function UpdateOverlayZOrder(dwFlags: DWORD; lpDDSReference: IDirectDrawSurface4): HResult; stdcall;
// IDirectDrawSurface2 methods
function GetDDInterface (out lplpDD: IUnknown) : HResult; stdcall;
function PageLock (dwFlags: DWORD) : HResult; stdcall;
function PageUnlock (dwFlags: DWORD) : HResult; stdcall;
(*** Added in the V3 interface ***)
function SetSurfaceDesc(const lpddsd2: TDDSurfaceDesc2; dwFlags: DWORD) : HResult; stdcall;
(*** Added in the v4 interface ***)
function SetPrivateData(const guidTag: TGUID; lpData: pointer;
// IDirectDrawSurface3 methods
function SetSurfaceDesc(const lpddsd: TDDSurfaceDesc2; dwFlags: DWORD): HResult; stdcall;
// IDirectDrawSurface4 methods
function SetPrivateData(const guidTag: TGUID; lpData: Pointer;
cbSize: DWORD; dwFlags: DWORD) : HResult; stdcall;
function GetPrivateData(const guidTag: TGUID; lpBuffer: pointer;
var lpcbBufferSize: DWORD) : HResult; stdcall;
function GetPrivateData(const guidTag: TGUID; lpData: Pointer;
var cbSize: DWORD): HResult; stdcall;
function FreePrivateData(const guidTag: TGUID) : HResult; stdcall;
function GetUniquenessValue(out lpValue: DWORD) : HResult; stdcall;
function GetUniquenessValue(var lpValue: DWORD): HResult; stdcall;
function ChangeUniquenessValue : HResult; stdcall;
end;
 
{ IDirectDrawSurface7 Interface }
 
IDirectDrawSurface7 = interface (IUnknown)
['{06675a80-3b9b-11d2-b92f-00609797ea5b}']
(*** IDirectDrawSurface methods ***)
function AddAttachedSurface (lpDDSAttachedSurface: IDirectDrawSurface7) :
HResult; stdcall;
['{06675A80-3B9B-11D2-B92F-00609797EA5B}']
// IDirectDrawSurface methods
function AddAttachedSurface(lpDDSAttachedSurface: IDirectDrawSurface7): HResult; stdcall;
function AddOverlayDirtyRect (const lpRect: TRect) : HResult; stdcall;
function Blt (lpDestRect: PRect;
lpDDSrcSurface: IDirectDrawSurface7; lpSrcRect: PRect;
dwFlags: DWORD; lpDDBltFx: PDDBltFX) : HResult; stdcall;
function Blt(const lpDestRect: TRect; lpDDSrcSurface: IDirectDrawSurface7;
const lpSrcRect: TRect; dwFlags: DWORD; const lpDDBltFx: TDDBltFX): HResult; stdcall;
function BltBatch (const lpDDBltBatch: TDDBltBatch; dwCount: DWORD;
dwFlags: DWORD) : HResult; stdcall;
function BltFast (dwX: DWORD; dwY: DWORD;
lpDDSrcSurface: IDirectDrawSurface7; lpSrcRect: PRect;
dwTrans: DWORD) : HResult; stdcall;
function BltFast(dwX, dwY: DWORD; lpDDSrcSurface: IDirectDrawSurface7;
const lpSrcRect: TRect; dwTrans: DWORD): HResult; stdcall;
function DeleteAttachedSurface (dwFlags: DWORD;
lpDDSAttachedSurface: IDirectDrawSurface7) : HResult; stdcall;
function EnumAttachedSurfaces (lpContext: Pointer;
1437,2038 → 1404,438
lpfnCallback: TDDEnumSurfacesCallback7) : HResult; stdcall;
function Flip (lpDDSurfaceTargetOverride: IDirectDrawSurface7;
dwFlags: DWORD) : HResult; stdcall;
function GetAttachedSurface (const lpDDSCaps: TDDSCaps2;
function GetAttachedSurface(var lpDDSCaps: TDDSCaps2;
out lplpDDAttachedSurface: IDirectDrawSurface7) : HResult; stdcall;
function GetBltStatus (dwFlags: DWORD) : HResult; stdcall;
function GetCaps (out lpDDSCaps: TDDSCaps2) : HResult; stdcall;
function GetCaps(var lpDDSCaps: TDDSCaps2): HResult; stdcall;
function GetClipper (out lplpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function GetColorKey (dwFlags: DWORD; out lpDDColorKey: TDDColorKey) :
HResult; stdcall;
function GetDC (out lphDC: HDC) : HResult; stdcall;
function GetColorKey(dwFlags: DWORD; var lpDDColorKey: TDDColorKey): HResult; stdcall;
function GetDC(var lphDC: HDC): HResult; stdcall;
function GetFlipStatus (dwFlags: DWORD) : HResult; stdcall;
function GetOverlayPosition (out lplX, lplY: LongInt) : HResult; stdcall;
function GetOverlayPosition(var lplX, lplY: Longint): HResult; stdcall;
function GetPalette (out lplpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function GetPixelFormat (out lpDDPixelFormat: TDDPixelFormat) : HResult; stdcall;
function GetSurfaceDesc (out lpDDSurfaceDesc: TDDSurfaceDesc2) : HResult; stdcall;
function Initialize (lpDD: IDirectDraw;
out lpDDSurfaceDesc: TDDSurfaceDesc2) : HResult; stdcall;
function GetPixelFormat(var lpDDPixelFormat: TDDPixelFormat): HResult; stdcall;
function GetSurfaceDesc(var lpDDSurfaceDesc: TDDSurfaceDesc2): HResult; stdcall;
function Initialize(lpDD: IDirectDraw; const lpDDSurfaceDesc: TDDSurfaceDesc2): HResult; stdcall;
function IsLost: HResult; stdcall;
function Lock (lpDestRect: PRect;
out lpDDSurfaceDesc: TDDSurfaceDesc2; dwFlags: DWORD;
hEvent: THandle) : HResult; stdcall;
function ReleaseDC (hDC: Windows.HDC) : HResult; stdcall;
function _Restore: HResult; stdcall;
function Lock(lpDestRect: PRect; const lpDDSurfaceDesc: TDDSurfaceDesc2;
dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
function ReleaseDC(hDC: HDC): HResult; stdcall;
function Restore: HResult; stdcall;
function SetClipper (lpDDClipper: IDirectDrawClipper) : HResult; stdcall;
function SetColorKey (dwFlags: DWORD; lpDDColorKey: PDDColorKey) :
HResult; stdcall;
function SetOverlayPosition (lX, lY: LongInt) : HResult; stdcall;
function SetColorKey(dwFlags: DWORD; const lpDDColorKey: TDDColorKey): HResult; stdcall;
function SetOverlayPosition(lX, lY: Longint): HResult; stdcall;
function SetPalette (lpDDPalette: IDirectDrawPalette) : HResult; stdcall;
function Unlock (lpRect: PRect) : HResult; stdcall;
function UpdateOverlay (lpSrcRect: PRect;
lpDDDestSurface: IDirectDrawSurface7; lpDestRect: PRect;
dwFlags: DWORD; lpDDOverlayFx: PDDOverlayFX) : HResult; stdcall;
function Unlock(lpSurfaceData: Pointer): HResult; stdcall;
function UpdateOverlay(const lpSrcRect: TRect; lpDDDestSurface: IDirectDrawSurface7;
const lpDestRect: TRect; dwFlags: DWORD; const lpDDOverlayFx: TDDOverlayFX): HResult; stdcall;
function UpdateOverlayDisplay (dwFlags: DWORD) : HResult; stdcall;
function UpdateOverlayZOrder (dwFlags: DWORD;
lpDDSReference: IDirectDrawSurface7) : HResult; stdcall;
(*** Added in the v2 interface ***)
function UpdateOverlayZOrder(dwFlags: DWORD; lpDDSReference: IDirectDrawSurface7): HResult; stdcall;
// IDirectDrawSurface2 methods
function GetDDInterface (out lplpDD: IUnknown) : HResult; stdcall;
function PageLock (dwFlags: DWORD) : HResult; stdcall;
function PageUnlock (dwFlags: DWORD) : HResult; stdcall;
(*** Added in the V3 interface ***)
function SetSurfaceDesc(const lpddsd2: TDDSurfaceDesc2; dwFlags: DWORD) : HResult; stdcall;
(*** Added in the v4 interface ***)
function SetPrivateData(const guidTag: TGUID; lpData: pointer;
// IDirectDrawSurface3 methods
function SetSurfaceDesc(const lpddsd: TDDSurfaceDesc2; dwFlags: DWORD): HResult; stdcall;
// IDirectDrawSurface4 methods
function SetPrivateData(const guidTag: TGUID; lpData: Pointer;
cbSize: DWORD; dwFlags: DWORD) : HResult; stdcall;
function GetPrivateData(const guidTag: TGUID; lpBuffer: pointer;
var lpcbBufferSize: DWORD) : HResult; stdcall;
function GetPrivateData(const guidTag: TGUID; lpData: Pointer;
var cbSize: DWORD): HResult; stdcall;
function FreePrivateData(const guidTag: TGUID) : HResult; stdcall;
function GetUniquenessValue(out lpValue: DWORD) : HResult; stdcall;
function GetUniquenessValue(var lpValue: DWORD): HResult; stdcall;
function ChangeUniquenessValue : HResult; stdcall;
(*** Moved Texture7 methods here ***)
// Moved Texture7 methods here
function SetPriority(dwPriority: DWORD) : HResult; stdcall;
function GetPriority(out lpdwPriority: DWORD) : HResult; stdcall;
function GetPriority(var lpdwPriority: DWORD): HResult; stdcall;
function SetLOD(dwMaxLOD: DWORD) : HResult; stdcall;
function GetLOD(out lpdwMaxLOD: DWORD) : HResult; stdcall;
function GetLOD(var lpdwMaxLOD: DWORD): HResult; stdcall;
end;
 
{ IDirectDrawColorControl Interface }
 
IDirectDrawColorControl = interface (IUnknown)
['{4B9F0EE0-0D7E-11D0-9B06-00A0C903A3B8}']
function GetColorControls(out lpColorControl: TDDColorControl) : HResult; stdcall;
// IDirectDrawColorControl methods
function GetColorControls(var lpColorControl: TDDColorControl): HResult; stdcall;
function SetColorControls(const lpColorControl: TDDColorControl) : HResult; stdcall;
end;
 
(*
* IDirectDrawGammaControl
*)
{ IDirectDrawGammaControl Interface }
 
IDirectDrawGammaControl = interface (IUnknown)
['{69C11C3E-B46B-11D1-AD7A-00C04FC29B4E}']
function GetGammaRamp (dwFlags: DWORD; out lpRampData: TDDGammaRamp)
: HResult; stdcall;
function SetGammaRamp (dwFlags: DWORD; const lpRampData: TDDGammaRamp)
: HResult; stdcall;
// IDirectDrawGammaControl methods
function GetGammaRamp(dwFlags: DWORD; var lpRampData: TDDGammaRamp): HResult; stdcall;
function SetGammaRamp(dwFlags: DWORD; const lpRampData: TDDGammaRamp): HResult; stdcall;
end;
 
type
IID_IDirectDraw = IDirectDraw;
IID_IDirectDraw2 = IDirectDraw2;
IID_IDirectDraw4 = IDirectDraw4;
IID_IDirectDraw7 = IDirectDraw7;
IID_IDirectDrawSurface = IDirectDrawSurface;
IID_IDirectDrawSurface2 = IDirectDrawSurface2;
IID_IDirectDrawSurface3 = IDirectDrawSurface3;
IID_IDirectDrawSurface4 = IDirectDrawSurface4;
IID_IDirectDrawSurface7 = IDirectDrawSurface7;
const
{ Flags for DirectDrawEnumerateEx }
DDENUM_ATTACHEDSECONDARYDEVICES = $00000001;
DDENUM_DETACHEDSECONDARYDEVICES = $00000002;
DDENUM_NONDISPLAYDEVICES = $00000004;
 
IID_IDirectDrawPalette = IDirectDrawPalette;
IID_IDirectDrawClipper = IDirectDrawClipper;
IID_IDirectDrawColorControl = IDirectDrawColorControl;
IID_IDirectDrawGammaControl = IDirectDrawGammaControl;
{ Flags for the IDirectDraw4.GetDeviceIdentifier method }
DDGDI_GETHOSTIDENTIFIER = $00000001;
 
const
(*
* ddsCaps field is valid.
*)
{ ddsCaps field is valid. }
DDSD_CAPS = $00000001; // default
 
(*
* dwHeight field is valid.
*)
DDSD_HEIGHT = $00000002;
 
(*
* dwWidth field is valid.
*)
DDSD_WIDTH = $00000004;
 
(*
* lPitch is valid.
*)
DDSD_PITCH = $00000008;
 
(*
* dwBackBufferCount is valid.
*)
DDSD_BACKBUFFERCOUNT = $00000020;
 
(*
* dwZBufferBitDepth is valid. (shouldnt be used in DDSURFACEDESC2)
*)
DDSD_ZBUFFERBITDEPTH = $00000040;
 
(*
* dwAlphaBitDepth is valid.
*)
DDSD_ALPHABITDEPTH = $00000080;
 
(*
* lpSurface is valid.
*)
DDSD_LPSURFACE = $00000800;
 
(*
* ddpfPixelFormat is valid.
*)
DDSD_PIXELFORMAT = $00001000;
 
(*
* ddckCKDestOverlay is valid.
*)
DDSD_CKDESTOVERLAY = $00002000;
 
(*
* ddckCKDestBlt is valid.
*)
DDSD_CKDESTBLT = $00004000;
 
(*
* ddckCKSrcOverlay is valid.
*)
DDSD_CKSRCOVERLAY = $00008000;
 
(*
* ddckCKSrcBlt is valid.
*)
DDSD_CKSRCBLT = $00010000;
 
(*
* dwMipMapCount is valid.
*)
DDSD_MIPMAPCOUNT = $00020000;
 
(*
* dwRefreshRate is valid
*)
DDSD_REFRESHRATE = $00040000;
 
(*
* dwLinearSize is valid
*)
DDSD_LINEARSIZE = $00080000;
 
(*
* dwTextureStage is valid
*)
DDSD_TEXTURESTAGE = $00100000;
DDSD_FVF = $00200000;
DDSD_SRCVBHANDLE = $00400000;
DDSD_ALL = $007ff9ee;
 
(*
* All input fields are valid.
*)
DDSD_ALL = $001ff9ee;
{ DirectDraw Driver Capability Flags }
 
 
(*
* guid field is valid.
*)
DDOSD_GUID = $00000001;
 
(*
* dwCompressionRatio field is valid.
*)
DDOSD_COMPRESSION_RATIO = $00000002;
 
(*
* ddSCaps field is valid.
*)
DDOSD_SCAPS = $00000004;
 
(*
* ddOSCaps field is valid.
*)
DDOSD_OSCAPS = $00000008;
 
(*
* All input fields are valid.
*)
DDOSD_ALL = $0000000f;
 
(*
* The surface's optimized pixelformat is compressed
*)
DDOSDCAPS_OPTCOMPRESSED = $00000001;
 
(*
* The surface's optimized pixelformat is reordered
*)
DDOSDCAPS_OPTREORDERED = $00000002;
 
(*
* The opt surface is a monolithic mipmap
*)
DDOSDCAPS_MONOLITHICMIPMAP = $00000004;
 
(*
* The valid Surf caps:
* DDSCAPS_SYSTEMMEMORY = $00000800;
* DDSCAPS_VIDEOMEMORY = $00004000;
* DDSCAPS_LOCALVIDMEM = $10000000;
* DDSCAPS_NONLOCALVIDMEM = $20000000;
*)
DDOSDCAPS_VALIDSCAPS = $30004800;
 
(*
* The valid OptSurf caps
*)
DDOSDCAPS_VALIDOSCAPS = $00000007;
 
 
(*
* DDCOLORCONTROL
*)
 
(*
* lBrightness field is valid.
*)
DDCOLOR_BRIGHTNESS = $00000001;
 
(*
* lContrast field is valid.
*)
DDCOLOR_CONTRAST = $00000002;
 
(*
* lHue field is valid.
*)
DDCOLOR_HUE = $00000004;
 
(*
* lSaturation field is valid.
*)
DDCOLOR_SATURATION = $00000008;
 
(*
* lSharpness field is valid.
*)
DDCOLOR_SHARPNESS = $00000010;
 
(*
* lGamma field is valid.
*)
DDCOLOR_GAMMA = $00000020;
 
(*
* lColorEnable field is valid.
*)
DDCOLOR_COLORENABLE = $00000040;
 
 
 
(*============================================================================
*
* Direct Draw Capability Flags
*
* These flags are used to describe the capabilities of a given Surface.
* All flags are bit flags.
*
*==========================================================================*)
 
(****************************************************************************
*
* DIRECTDRAWSURFACE CAPABILITY FLAGS
*
****************************************************************************)
(*
* This bit currently has no meaning.
*)
DDSCAPS_RESERVED1 = $00000001;
 
(*
* Indicates that this surface contains alpha-only information.
* (To determine if a surface is RGBA/YUVA, the pixel format must be
* interrogated.)
*)
DDSCAPS_ALPHA = $00000002;
 
(*
* Indicates that this surface is a backbuffer. It is generally
* set by CreateSurface when the DDSCAPS_FLIP capability bit is set.
* It indicates that this surface is THE back buffer of a surface
* flipping structure. DirectDraw supports N surfaces in a
* surface flipping structure. Only the surface that immediately
* precedeces the DDSCAPS_FRONTBUFFER has this capability bit set.
* The other surfaces are identified as back buffers by the presence
* of the DDSCAPS_FLIP capability, their attachment order, and the
* absence of the DDSCAPS_FRONTBUFFER and DDSCAPS_BACKBUFFER
* capabilities. The bit is sent to CreateSurface when a standalone
* back buffer is being created. This surface could be attached to
* a front buffer and/or back buffers to form a flipping surface
* structure after the CreateSurface call. See AddAttachments for
* a detailed description of the behaviors in this case.
*)
DDSCAPS_BACKBUFFER = $00000004;
 
(*
* Indicates a complex surface structure is being described. A
* complex surface structure results in the creation of more than
* one surface. The additional surfaces are attached to the root
* surface. The complex structure can only be destroyed by
* destroying the root.
*)
DDSCAPS_COMPLEX = $00000008;
 
(*
* Indicates that this surface is a part of a surface flipping structure.
* When it is passed to CreateSurface the DDSCAPS_FRONTBUFFER and
* DDSCAP_BACKBUFFER bits are not set. They are set by CreateSurface
* on the resulting creations. The dwBackBufferCount field in the
* TDDSurfaceDesc structure must be set to at least 1 in order for
* the CreateSurface call to succeed. The DDSCAPS_COMPLEX capability
* must always be set with creating multiple surfaces through CreateSurface.
*)
DDSCAPS_FLIP = $00000010;
 
(*
* Indicates that this surface is THE front buffer of a surface flipping
* structure. It is generally set by CreateSurface when the DDSCAPS_FLIP
* capability bit is set.
* If this capability is sent to CreateSurface then a standalonw front buffer
* is created. This surface will not have the DDSCAPS_FLIP capability.
* It can be attached to other back buffers to form a flipping structure.
* See AddAttachments for a detailed description of the behaviors in this
* case.
*)
DDSCAPS_FRONTBUFFER = $00000020;
 
(*
* Indicates that this surface is any offscreen surface that is not an overlay,
* texture, zbuffer, front buffer, back buffer, or alpha surface. It is used
* to identify plain vanilla surfaces.
*)
DDSCAPS_OFFSCREENPLAIN = $00000040;
 
(*
* Indicates that this surface is an overlay. It may or may not be directly visible
* depending on whether or not it is currently being overlayed onto the primary
* surface. DDSCAPS_VISIBLE can be used to determine whether or not it is being
* overlayed at the moment.
*)
DDSCAPS_OVERLAY = $00000080;
 
(*
* Indicates that unique DirectDrawPalette objects can be created and
* attached to this surface.
*)
DDSCAPS_PALETTE = $00000100;
 
(*
* Indicates that this surface is the primary surface. The primary
* surface represents what the user is seeing at the moment.
*)
DDSCAPS_PRIMARYSURFACE = $00000200;
 
(*
* This flag used to be DDSCAPS_PRIMARYSURFACELEFT, which is now
* obsolete.
*)
DDSCAPS_RESERVED3 = $00000400;
(*
* Indicates that this surface is the primary surface for the left eye.
* The primary surface for the left eye represents what the user is seeing
* at the moment with the users left eye. When this surface is created the
* DDSCAPS_PRIMARYSURFACE represents what the user is seeing with the users
* right eye.
*)
DDSCAPS_PRIMARYSURFACELEFT = DDSCAPS_RESERVED3;
 
(*
* Indicates that this surface memory was allocated in system memory
*)
DDSCAPS_SYSTEMMEMORY = $00000800;
 
(*
* Indicates that this surface can be used as a 3D texture. It does not
* indicate whether or not the surface is being used for that purpose.
*)
DDSCAPS_TEXTURE = $00001000;
 
(*
* Indicates that a surface may be a destination for 3D rendering. This
* bit must be set in order to query for a Direct3D Device Interface
* from this surface.
*)
DDSCAPS_3DDEVICE = $00002000;
 
(*
* Indicates that this surface exists in video memory.
*)
DDSCAPS_VIDEOMEMORY = $00004000;
 
(*
* Indicates that changes made to this surface are immediately visible.
* It is always set for the primary surface and is set for overlays while
* they are being overlayed and texture maps while they are being textured.
*)
DDSCAPS_VISIBLE = $00008000;
 
(*
* Indicates that only writes are permitted to the surface. Read accesses
* from the surface may or may not generate a protection fault, but the
* results of a read from this surface will not be meaningful. READ ONLY.
*)
DDSCAPS_WRITEONLY = $00010000;
 
(*
* Indicates that this surface is a z buffer. A z buffer does not contain
* displayable information. Instead it contains bit depth information that is
* used to determine which pixels are visible and which are obscured.
*)
DDSCAPS_ZBUFFER = $00020000;
 
(*
* Indicates surface will have a DC associated long term
*)
DDSCAPS_OWNDC = $00040000;
 
(*
* Indicates surface should be able to receive live video
*)
DDSCAPS_LIVEVIDEO = $00080000;
 
(*
* Indicates surface should be able to have a stream decompressed
* to it by the hardware.
*)
DDSCAPS_HWCODEC = $00100000;
 
(*
* Surface is a ModeX surface.
*
*)
DDSCAPS_MODEX = $00200000;
 
(*
* Indicates surface is one level of a mip-map. This surface will
* be attached to other DDSCAPS_MIPMAP surfaces to form the mip-map.
* This can be done explicitly, by creating a number of surfaces and
* attaching them with AddAttachedSurface or by implicitly by CreateSurface.
* If this bit is set then DDSCAPS_TEXTURE must also be set.
*)
DDSCAPS_MIPMAP = $00400000;
 
(*
* This bit is reserved. It should not be specified.
*)
DDSCAPS_RESERVED2 = $00800000;
 
(*
* Indicates that memory for the surface is not allocated until the surface
* is loaded (via the Direct3D texture Load() function).
*)
DDSCAPS_ALLOCONLOAD = $04000000;
 
(*
* Indicates that the surface will recieve data from a video port.
*)
DDSCAPS_VIDEOPORT = $08000000;
 
(*
* Indicates that a video memory surface is resident in true, local video
* memory rather than non-local video memory. If this flag is specified then
* so must DDSCAPS_VIDEOMEMORY. This flag is mutually exclusive with
* DDSCAPS_NONLOCALVIDMEM.
*)
DDSCAPS_LOCALVIDMEM = $10000000;
 
(*
* Indicates that a video memory surface is resident in non-local video
* memory rather than true, local video memory. If this flag is specified
* then so must DDSCAPS_VIDEOMEMORY. This flag is mutually exclusive with
* DDSCAPS_LOCALVIDMEM.
*)
DDSCAPS_NONLOCALVIDMEM = $20000000;
 
(*
* Indicates that this surface is a standard VGA mode surface, and not a
* ModeX surface. (This flag will never be set in combination with the
* DDSCAPS_MODEX flag).
*)
DDSCAPS_STANDARDVGAMODE = $40000000;
 
(*
* Indicates that this surface will be an optimized surface. This flag is
* currently only valid in conjunction with the DDSCAPS_TEXTURE flag. The surface
* will be created without any underlying video memory until loaded.
*)
DDSCAPS_OPTIMIZED = $80000000;
 
 
 
(*
* Indicates that this surface will receive data from a video port using
* the de-interlacing hardware. This allows the driver to allocate memory
* for any extra buffers that may be required. The DDSCAPS_VIDEOPORT and
* DDSCAPS_OVERLAY flags must also be set.
*)
DDSCAPS2_HARDWAREDEINTERLACE = $00000002;
 
(*
* Indicates to the driver that this surface will be locked very frequently
* (for procedural textures, dynamic lightmaps, etc). Surfaces with this cap
* set must also have DDSCAPS_TEXTURE. This cap cannot be used with
* DDSCAPS2_HINTSTATIC and DDSCAPS2_OPAQUE.
*)
DDSCAPS2_HINTDYNAMIC = $00000004;
 
(*
* Indicates to the driver that this surface can be re-ordered/retiled on
* load. This operation will not change the size of the texture. It is
* relatively fast and symmetrical, since the application may lock these
* bits (although it will take a performance hit when doing so). Surfaces
* with this cap set must also have DDSCAPS_TEXTURE. This cap cannot be
* used with DDSCAPS2_HINTDYNAMIC and DDSCAPS2_OPAQUE.
*)
DDSCAPS2_HINTSTATIC = $00000008;
 
(*
* Indicates that the client would like this texture surface to be managed by the
* DirectDraw/Direct3D runtime. Surfaces with this cap set must also have
* DDSCAPS_TEXTURE and DDSCAPS_SYSTEMMEMORY.
*)
DDSCAPS2_TEXTUREMANAGE = $00000010;
 
(*
* These bits are reserved for internal use *)
DDSCAPS2_RESERVED1 = $00000020;
DDSCAPS2_RESERVED2 = $00000040;
 
(*
* Indicates to the driver that this surface will never be locked again.
* The driver is free to optimize this surface via retiling and actual compression.
* All calls to Lock() or Blts from this surface will fail. Surfaces with this
* cap set must also have DDSCAPS_TEXTURE. This cap cannot be used with
* DDSCAPS2_HINTDYNAMIC and DDSCAPS2_HINTSTATIC.
*)
DDSCAPS2_OPAQUE = $00000080;
 
(*
* Applications should set this bit at CreateSurface time to indicate that they
* intend to use antialiasing. Only valid if DDSCAPS_3DDEVICE is also set.
*)
DDSCAPS2_HINTANTIALIASING = $00000100;
 
(*
* This flag is used at CreateSurface time to indicate that this set of
* surfaces is a cubic environment map
*)
DDSCAPS2_CUBEMAP = $00000200;
 
(*
* These flags preform two functions:
* - At CreateSurface time, they define which of the six cube faces are
* required by the application.
* - After creation, each face in the cubemap will have exactly one of these
* bits set.
*)
DDSCAPS2_CUBEMAP_POSITIVEX = $00000400;
DDSCAPS2_CUBEMAP_NEGATIVEX = $00000800;
DDSCAPS2_CUBEMAP_POSITIVEY = $00001000;
DDSCAPS2_CUBEMAP_NEGATIVEY = $00002000;
DDSCAPS2_CUBEMAP_POSITIVEZ = $00004000;
DDSCAPS2_CUBEMAP_NEGATIVEZ = $00008000;
 
(*
* This macro may be used to specify all faces of a cube map at CreateSurface time
*)
DDSCAPS2_CUBEMAP_ALLFACES = ( DDSCAPS2_CUBEMAP_POSITIVEX or
DDSCAPS2_CUBEMAP_NEGATIVEX or
DDSCAPS2_CUBEMAP_POSITIVEY or
DDSCAPS2_CUBEMAP_NEGATIVEY or
DDSCAPS2_CUBEMAP_POSITIVEZ or
DDSCAPS2_CUBEMAP_NEGATIVEZ );
 
 
(*
* This flag is an additional flag which is present on mipmap sublevels from DX7 onwards
* It enables easier use of GetAttachedSurface rather than EnumAttachedSurfaces for surface
* constructs such as Cube Maps, wherein there are more than one mipmap surface attached
* to the root surface.
* This caps bit is ignored by CreateSurface
*)
DDSCAPS2_MIPMAPSUBLEVEL = $00010000;
 
(* This flag indicates that the texture should be managed by D3D only *)
DDSCAPS2_D3DTEXTUREMANAGE = $00020000;
 
(* This flag indicates that the managed surface can be safely lost *)
DDSCAPS2_DONOTPERSIST = $00040000;
 
(* indicates that this surface is part of a stereo flipping chain *)
DDSCAPS2_STEREOSURFACELEFT = $00080000;
 
 
 
(****************************************************************************
*
* DIRECTDRAW DRIVER CAPABILITY FLAGS
*
****************************************************************************)
 
(*
* Display hardware has 3D acceleration.
*)
DDCAPS_3D = $00000001;
 
(*
* Indicates that DirectDraw will support only dest rectangles that are aligned
* on DIRECTDRAWCAPS.dwAlignBoundaryDest boundaries of the surface, respectively.
* READ ONLY.
*)
DDCAPS_ALIGNBOUNDARYDEST = $00000002;
 
(*
* Indicates that DirectDraw will support only source rectangles whose sizes in
* BYTEs are DIRECTDRAWCAPS.dwAlignSizeDest multiples, respectively. READ ONLY.
*)
DDCAPS_ALIGNSIZEDEST = $00000004;
(*
* Indicates that DirectDraw will support only source rectangles that are aligned
* on DIRECTDRAWCAPS.dwAlignBoundarySrc boundaries of the surface, respectively.
* READ ONLY.
*)
DDCAPS_ALIGNBOUNDARYSRC = $00000008;
 
(*
* Indicates that DirectDraw will support only source rectangles whose sizes in
* BYTEs are DIRECTDRAWCAPS.dwAlignSizeSrc multiples, respectively. READ ONLY.
*)
DDCAPS_ALIGNSIZESRC = $00000010;
 
(*
* Indicates that DirectDraw will create video memory surfaces that have a stride
* alignment equal to DIRECTDRAWCAPS.dwAlignStride. READ ONLY.
*)
DDCAPS_ALIGNSTRIDE = $00000020;
 
(*
* Display hardware is capable of blt operations.
*)
DDCAPS_BLT = $00000040;
 
(*
* Display hardware is capable of asynchronous blt operations.
*)
DDCAPS_BLTQUEUE = $00000080;
 
(*
* Display hardware is capable of color space conversions during the blt operation.
*)
DDCAPS_BLTFOURCC = $00000100;
 
(*
* Display hardware is capable of stretching during blt operations.
*)
DDCAPS_BLTSTRETCH = $00000200;
 
(*
* Display hardware is shared with GDI.
*)
DDCAPS_GDI = $00000400;
 
(*
* Display hardware can overlay.
*)
DDCAPS_OVERLAY = $00000800;
 
(*
* Set if display hardware supports overlays but can not clip them.
*)
DDCAPS_OVERLAYCANTCLIP = $00001000;
 
(*
* Indicates that overlay hardware is capable of color space conversions during
* the overlay operation.
*)
DDCAPS_OVERLAYFOURCC = $00002000;
 
(*
* Indicates that stretching can be done by the overlay hardware.
*)
DDCAPS_OVERLAYSTRETCH = $00004000;
 
(*
* Indicates that unique DirectDrawPalettes can be created for DirectDrawSurfaces
* other than the primary surface.
*)
DDCAPS_PALETTE = $00008000;
 
(*
* Indicates that palette changes can be syncd with the veritcal refresh.
*)
DDCAPS_PALETTEVSYNC = $00010000;
 
(*
* Display hardware can return the current scan line.
*)
DDCAPS_READSCANLINE = $00020000;
 
(*
* Display hardware has stereo vision capabilities. DDSCAPS_PRIMARYSURFACELEFT
* can be created.
*)
DDCAPS_STEREOVIEW = $00040000;
 
(*
* Display hardware is capable of generating a vertical blank interrupt.
*)
DDCAPS_VBI = $00080000;
 
(*
* Supports the use of z buffers with blt operations.
*)
DDCAPS_ZBLTS = $00100000;
 
(*
* Supports Z Ordering of overlays.
*)
DDCAPS_ZOVERLAYS = $00200000;
 
(*
* Supports color key
*)
DDCAPS_COLORKEY = $00400000;
 
(*
* Supports alpha surfaces
*)
DDCAPS_ALPHA = $00800000;
 
(*
* colorkey is hardware assisted(DDCAPS_COLORKEY will also be set)
*)
DDCAPS_COLORKEYHWASSIST = $01000000;
 
(*
* no hardware support at all
*)
DDCAPS_NOHARDWARE = $02000000;
 
(*
* Display hardware is capable of color fill with bltter
*)
DDCAPS_BLTCOLORFILL = $04000000;
 
(*
* Display hardware is bank switched, and potentially very slow at
* random access to VRAM.
*)
DDCAPS_BANKSWITCHED = $08000000;
 
(*
* Display hardware is capable of depth filling Z-buffers with bltter
*)
DDCAPS_BLTDEPTHFILL = $10000000;
 
(*
* Display hardware is capable of clipping while bltting.
*)
DDCAPS_CANCLIP = $20000000;
 
(*
* Display hardware is capable of clipping while stretch bltting.
*)
DDCAPS_CANCLIPSTRETCHED = $40000000;
 
(*
* Display hardware is capable of bltting to or from system memory
*)
DDCAPS_CANBLTSYSMEM = $80000000;
 
{ More DirectDraw Driver Capability Flags (dwCaps2) }
 
(****************************************************************************
*
* MORE DIRECTDRAW DRIVER CAPABILITY FLAGS (dwCaps2)
*
****************************************************************************)
 
(*
* Display hardware is certified
*)
DDCAPS2_CERTIFIED = $00000001;
 
(*
* Driver cannot interleave 2D operations (lock and blt) to surfaces with
* Direct3D rendering operations between calls to BeginScene() and EndScene()
*)
DDCAPS2_NO2DDURING3DSCENE = $00000002;
 
(*
* Display hardware contains a video port
*)
DDCAPS2_VIDEOPORT = $00000004;
 
(*
* The overlay can be automatically flipped according to the video port
* VSYNCs, providing automatic doubled buffered display of video port
* data using an overlay
*)
DDCAPS2_AUTOFLIPOVERLAY = $00000008;
 
(*
* Overlay can display each field of interlaced data individually while
* it is interleaved in memory without causing jittery artifacts.
*)
DDCAPS2_CANBOBINTERLEAVED = $00000010;
 
(*
* Overlay can display each field of interlaced data individually while
* it is not interleaved in memory without causing jittery artifacts.
*)
DDCAPS2_CANBOBNONINTERLEAVED = $00000020;
 
(*
* The overlay surface contains color controls (brightness, sharpness, etc.)
*)
DDCAPS2_COLORCONTROLOVERLAY = $00000040;
 
(*
* The primary surface contains color controls (gamma, etc.)
*)
DDCAPS2_COLORCONTROLPRIMARY = $00000080;
 
(*
* RGBZ -> RGB supported for 16:16 RGB:Z
*)
DDCAPS2_CANDROPZ16BIT = $00000100;
 
(*
* Driver supports non-local video memory.
*)
DDCAPS2_NONLOCALVIDMEM = $00000200;
 
(*
* Dirver supports non-local video memory but has different capabilities for
* non-local video memory surfaces. If this bit is set then so must
* DDCAPS2_NONLOCALVIDMEM.
*)
DDCAPS2_NONLOCALVIDMEMCAPS = $00000400;
 
(*
* Driver neither requires nor prefers surfaces to be pagelocked when performing
* blts involving system memory surfaces
*)
DDCAPS2_NOPAGELOCKREQUIRED = $00000800;
 
(*
* Driver can create surfaces which are wider than the primary surface
*)
DDCAPS2_WIDESURFACES = $00001000;
 
(*
* Driver supports bob without using a video port by handling the
* DDFLIP_ODD and DDFLIP_EVEN flags specified in Flip.
*)
DDCAPS2_CANFLIPODDEVEN = $00002000;
 
(*
* Driver supports bob using hardware
*)
DDCAPS2_CANBOBHARDWARE = $00004000;
 
(*
* Driver supports bltting any FOURCC surface to another surface of the same FOURCC
*)
DDCAPS2_COPYFOURCC = $00008000;
DDCAPS2_PRIMARYGAMMA = $00020000;
DDCAPS2_CANRENDERWINDOWED = $00080000;
DDCAPS2_CANCALIBRATEGAMMA = $00100000;
DDCAPS2_FLIPINTERVAL = $00200000;
DDCAPS2_FLIPNOVSYNC = $00400000;
DDCAPS2_CANMANAGETEXTURE = $00800000;
DDCAPS2_TEXMANINNONLOCALVIDMEM = $01000000;
DDCAPS2_STEREO = $02000000;
DDCAPS2_SYSTONONLOCAL_AS_SYSTOLOCAL = $04000000;
 
{ DirectDrawSurface Capability Flags }
 
(*
* Driver supports loadable gamma ramps for the primary surface
*)
DDCAPS2_PRIMARYGAMMA = $00020000;
DDSCAPS_RESERVED1 = $00000001; { DDSCAPS_3D }
DDSCAPS_ALPHA = $00000002;
DDSCAPS_BACKBUFFER = $00000004;
DDSCAPS_COMPLEX = $00000008;
DDSCAPS_FLIP = $00000010;
DDSCAPS_FRONTBUFFER = $00000020;
DDSCAPS_OFFSCREENPLAIN = $00000040;
DDSCAPS_OVERLAY = $00000080;
DDSCAPS_PALETTE = $00000100;
DDSCAPS_PRIMARYSURFACE = $00000200;
DDSCAPS_RESERVED3 = $00000400; { DDSCAPS_PRIMARYSURFACELEFT }
DDSCAPS_SYSTEMMEMORY = $00000800;
DDSCAPS_TEXTURE = $00001000;
DDSCAPS_3DDEVICE = $00002000;
DDSCAPS_VIDEOMEMORY = $00004000;
DDSCAPS_VISIBLE = $00008000;
DDSCAPS_WRITEONLY = $00010000;
DDSCAPS_ZBUFFER = $00020000;
DDSCAPS_OWNDC = $00040000;
DDSCAPS_LIVEVIDEO = $00080000;
DDSCAPS_HWCODEC = $00100000;
DDSCAPS_MODEX = $00200000;
DDSCAPS_MIPMAP = $00400000;
DDSCAPS_RESERVED2 = $00800000;
DDSCAPS_ALLOCONLOAD = $04000000;
DDSCAPS_VIDEOPORT = $08000000;
DDSCAPS_LOCALVIDMEM = $10000000;
DDSCAPS_NONLOCALVIDMEM = $20000000;
DDSCAPS_STANDARDVGAMODE = $40000000;
DDSCAPS_OPTIMIZED = $80000000;
 
(*
* Driver can render in windowed mode.
*)
DDCAPS2_CANRENDERWINDOWED = $00080000;
{ DirectDrawSurface Capability Flags 2 }
 
(*
* A calibrator is available to adjust the gamma ramp according to the
* physical display properties so that the result will be identical on
* all calibrated systems.
*)
DDCAPS2_CANCALIBRATEGAMMA = $00100000;
DDSCAPS2_HARDWAREDEINTERLACE = $00000002;
DDSCAPS2_HINTDYNAMIC = $00000004;
DDSCAPS2_HINTSTATIC = $00000008;
DDSCAPS2_TEXTUREMANAGE = $00000010;
DDSCAPS2_RESERVED1 = $00000020;
DDSCAPS2_RESERVED2 = $00000040;
DDSCAPS2_OPAQUE = $00000080;
DDSCAPS2_HINTANTIALIASING = $00000100;
DDSCAPS2_CUBEMAP = $00000200;
DDSCAPS2_CUBEMAP_POSITIVEX = $00000400;
DDSCAPS2_CUBEMAP_NEGATIVEX = $00000800;
DDSCAPS2_CUBEMAP_POSITIVEY = $00001000;
DDSCAPS2_CUBEMAP_NEGATIVEY = $00002000;
DDSCAPS2_CUBEMAP_POSITIVEZ = $00004000;
DDSCAPS2_CUBEMAP_NEGATIVEZ = $00008000;
 
(*
* Indicates that the driver will respond to DDFLIP_INTERVALn flags
*)
DDCAPS2_FLIPINTERVAL = $00200000;
DDSCAPS2_CUBEMAP_ALLFACES =
DDSCAPS2_CUBEMAP_POSITIVEX or DDSCAPS2_CUBEMAP_NEGATIVEX or
DDSCAPS2_CUBEMAP_POSITIVEY or DDSCAPS2_CUBEMAP_NEGATIVEY or
DDSCAPS2_CUBEMAP_POSITIVEZ or DDSCAPS2_CUBEMAP_NEGATIVEZ;
 
(*
* Indicates that the driver will respond to DDFLIP_NOVSYNC
*)
DDCAPS2_FLIPNOVSYNC = $00400000;
DDSCAPS2_MIPMAPSUBLEVEL = $00010000;
DDSCAPS2_D3DTEXTUREMANAGE = $00020000;
DDSCAPS2_DONOTPERSIST = $00040000;
DDSCAPS2_STEREOSURFACELEFT = $00080000;
 
(*
* Driver supports management of video memory, if this flag is ON,
* driver manages the texture if requested with DDSCAPS2_TEXTUREMANAGE on
* DirectX manages the texture if this flag is OFF and surface has DDSCAPS2_TEXTUREMANAGE on
*)
DDCAPS2_CANMANAGETEXTURE = $00800000;
{ TDDOptSurfaceDesc flags }
 
(*
* The Direct3D texture manager uses this cap to decide whether to put managed
* surfaces in non-local video memory. If the cap is set, the texture manager will
* put managed surfaces in non-local vidmem. Drivers that cannot texture from
* local vidmem SHOULD NOT set this cap.
*)
DDCAPS2_TEXMANINNONLOCALVIDMEM = $01000000;
DDOSD_GUID = $00000001;
DDOSD_COMPRESSION_RATIO = $00000002;
DDOSD_SCAPS = $00000004;
DDOSD_OSCAPS = $00000008;
DDOSD_ALL = $0000000F;
 
(*
* Indicates that the driver supports DX7 type of stereo in at least one mode (which may
* not necessarily be the current mode). Applications should use IDirectDraw7 (or higher)
* ::EnumDisplayModes and check the DDSURFACEDESC.ddsCaps.dwCaps2 field for the presence of
* DDSCAPS2_STEREOSURFACELEFT to check if a particular mode supports stereo. The application
* can also use IDirectDraw7(or higher)::GetDisplayMode to check the current mode.
*)
DDCAPS2_STEREO = $02000000;
{ ddOSCaps field is valid. }
 
(*
* This caps bit is intended for internal DirectDraw use.
* -It is only valid if DDCAPS2_NONLOCALVIDMEMCAPS is set.
* -If this bit is set, then DDCAPS_CANBLTSYSMEM MUST be set by the driver (and
* all the assoicated system memory blt caps must be correct).
* -It implies that the system->video blt caps in DDCAPS also apply to system to
* nonlocal blts. I.e. the dwSVBCaps, dwSVBCKeyCaps, dwSVBFXCaps and dwSVBRops
* members of DDCAPS (DDCORECAPS) are filled in correctly.
* -Any blt from system to nonlocal memory that matches these caps bits will
* be passed to the driver.
*
* NOTE: This is intended to enable the driver itself to do efficient reordering
* of textures. This is NOT meant to imply that hardware can write into AGP memory.
* This operation is not currently supported.
*)
DDCAPS2_SYSTONONLOCAL_AS_SYSTOLOCAL = $04000000;
DDOSDCAPS_OPTCOMPRESSED = $00000001;
DDOSDCAPS_OPTREORDERED = $00000002;
DDOSDCAPS_MONOLITHICMIPMAP = $00000004;
DDOSDCAPS_VALIDSCAPS = $30004800;
DDOSDCAPS_VALIDOSCAPS = $00000007;
 
(****************************************************************************
*
* DIRECTDRAW FX ALPHA CAPABILITY FLAGS
*
****************************************************************************)
{ DirectDraw FX Alpha Capability Flags }
 
(*
* Supports alpha blending around the edge of a source color keyed surface.
* For Blt.
*)
DDFXALPHACAPS_BLTALPHAEDGEBLEND = $00000001;
 
(*
* Supports alpha information in the pixel format. The bit depth of alpha
* information in the pixel format can be 1,2,4, or 8. The alpha value becomes
* more opaque as the alpha value increases. (0 is transparent.)