Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
Some time ago, I posted a workaround for blurring userforms using a gdi32 alphablend algorithm.
Lately, I have been exploring other ways and came accross Direct2D and Windows Imaging Component graphics apis for higher quality and better performance rendering (minimum system requirements Win7). These apis are more powerful than GDI and GDIPlus, however, since these are mostly com interface based, their code is wrapped in type libs and therfore they are a bit trickier to use at run time for the avearge vba coder.
In this thread, I would like to post my first baby steps using these apis which allowed me to achieve faster and more flexible blurring (glass) effects on images (bmp,jpg,png ... ). I hope this will be of use to vba users as well.
In the code below, you will find BlurImageFromFile and BlurImageFromImageHandle and as their names suggest, these are two easy to use custom functions that return a vba StdPicture object. One expects an image file and the other expects a StdPic handle. Also, you can optionally set the blur radius (intensity) and/or the image scaling via the functions optional arguments.
File Demo:
BlurDirect2D.xlsm
Code written and tested in x32 and x64 bit. So far, no issues found ... No external libraries are needed. Just plug the code and play.
1- In a Standard Module:
2- Code usage example:
Lately, I have been exploring other ways and came accross Direct2D and Windows Imaging Component graphics apis for higher quality and better performance rendering (minimum system requirements Win7). These apis are more powerful than GDI and GDIPlus, however, since these are mostly com interface based, their code is wrapped in type libs and therfore they are a bit trickier to use at run time for the avearge vba coder.
In this thread, I would like to post my first baby steps using these apis which allowed me to achieve faster and more flexible blurring (glass) effects on images (bmp,jpg,png ... ). I hope this will be of use to vba users as well.
In the code below, you will find BlurImageFromFile and BlurImageFromImageHandle and as their names suggest, these are two easy to use custom functions that return a vba StdPicture object. One expects an image file and the other expects a StdPic handle. Also, you can optionally set the blur radius (intensity) and/or the image scaling via the functions optional arguments.
File Demo:
BlurDirect2D.xlsm
Code written and tested in x32 and x64 bit. So far, no issues found ... No external libraries are needed. Just plug the code and play.
1- In a Standard Module:
VBA Code:
Option Explicit
#If Win64 Then
Private Const NULL_PTR = 0^
Private Const PTR_LEN = 8&
#Else
Private Const NULL_PTR = 0&
Private Const PTR_LEN = 4&
#End If
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As LongPtr)
Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, ByVal prgvt As LongPtr, ByVal prgpvarg As LongPtr, ByRef pvargResult As Variant) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef lplpvObj As Object) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "Ole32.dll" (ByVal pstring As LongPtr, ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "Gdi32.dll" (ByVal hdc As LongPtr, ByRef pbmi As BITMAPINFO, ByVal usage As Long, ByVal ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal offset As Long) As LongPtr
Private Declare PtrSafe Function SetDIBits Lib "Gdi32.dll" (ByVal hdc As LongPtr, ByVal hbitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, ByVal lpBits As LongPtr, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare PtrSafe Function CreateD2D1Factory Lib "D2d1.dll" Alias "D2D1CreateFactory" (ByVal factoryType As LongPtr, ByRef riid As GUID, ByRef pFactoryOptions As D2D1_FACTORY_OPTIONS, ByRef ppID2D1Factory As LongPtr) As Long
Private Declare PtrSafe Function CreateWICFactory Lib "Windowscodecs.dll" Alias "WICCreateImagingFactory_Proxy" (ByVal sdkVersion As Long, ByRef ppIWICImagingFactory As LongPtr) As Long
Private Declare PtrSafe Function CreateWICBitmap Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateBitmap_Proxy" (ByVal pIWICImagingFactory As LongPtr, ByVal uiWidth As Long, ByVal uiHeight As Long, ByRef PixelFormat As GUID, ByVal eOption As Long, ByRef ppIWICBitmap As LongPtr) As Long
Private Declare PtrSafe Function CreateWICDecoderFromFilename Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateDecoderFromFilename_Proxy" (ByVal pFactory As LongPtr, ByVal wzFilename As LongPtr, ByVal pguidVendor As LongPtr, ByVal dwDesiredAccess As Long, ByVal metadataOptions As Long, ByRef ppIDecoder As LongPtr) As Long
Private Declare PtrSafe Function GetWICFrameCount Lib "Windowscodecs.dll" Alias "IWICBitmapDecoder_GetFrameCount_Proxy" (ByVal pIWICDecoder As LongPtr, ByRef pCount As Long) As Long
Private Declare PtrSafe Function GetWICFrame Lib "Windowscodecs.dll" Alias "IWICBitmapDecoder_GetFrame_Proxy" (ByVal pIWICDecoder As LongPtr, ByVal index As Long, ByRef ppIBitmapFrame As LongPtr) As Long
Private Declare PtrSafe Function ConvertWICBitmap Lib "Windowscodecs.dll" Alias "WICConvertBitmapSource" (ByRef dstFormat As GUID, ByVal pISrc As LongPtr, ByRef ppIDst As LongPtr) As Long
Private Declare PtrSafe Function CreateWICBitmapFromSource Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateBitmapFromSource_Proxy" (ByVal pFactory As LongPtr, ByVal pIBitmapSource As LongPtr, ByVal eOption As Long, ByRef ppIBitmap As LongPtr) As Long
Private Declare PtrSafe Function CreateBitmapFromHBITMAP Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateBitmapFromHBITMAP_Proxy" (ByVal pFactory As LongPtr, ByVal hbitmap As LongPtr, ByVal hPalette As LongPtr, ByVal eOption As Long, ByRef ppIBitmap As LongPtr) As Long
Private Declare PtrSafe Function GetWICBitmapSourceSize Lib "Windowscodecs.dll" Alias "IWICBitmapSource_GetSize_Proxy" (ByVal pIWICBitmapSource As LongPtr, ByRef puiWidth As Long, ByRef puiHeight As Long) As Long
Private Declare PtrSafe Function LockWICBitmap Lib "Windowscodecs.dll" Alias "IWICBitmap_Lock_Proxy" (ByVal pIBitmap As LongPtr, ByRef prcLock As WICRect, ByVal lockFlags As Long, ByRef ppILock As LongPtr) As Long
Private Declare PtrSafe Function GetWICLockDataPointer Lib "Windowscodecs.dll" Alias "IWICBitmapLock_GetDataPointer_STA_Proxy" (ByVal pILock As LongPtr, ByRef pcbBufferSize As Long, ByRef ppbData As LongPtr) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As LongPtr)
Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, ByVal prgvt As LongPtr, ByVal prgpvarg As LongPtr, ByRef pvargResult As Variant) As LongPtr
Private Declare Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef lplpvObj As Object) As Long
Private Declare Function CLSIDFromString Lib "Ole32.dll" (ByVal pstring As LongPtr, ByRef pCLSID As GUID) As Long
Private Declare Function CreateDIBSection Lib "Gdi32.dll" (ByVal hdc As LongPtr, ByRef pbmi As BITMAPINFO, ByVal usage As Long, ByVal ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal offset As Long) As LongPtr
Private Declare Function SetDIBits Lib "Gdi32.dll" (ByVal hdc As LongPtr, ByVal hbitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, ByVal lpBits As LongPtr, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateD2D1Factory Lib "D2d1.dll" Alias "D2D1CreateFactory" (ByVal factoryType As LongPtr, ByRef riid As GUID, ByRef pFactoryOptions As D2D1_FACTORY_OPTIONS, ByRef ppID2D1Factory As LongPtr) As Long
Private Declare Function CreateWICFactory Lib "Windowscodecs.dll" Alias "WICCreateImagingFactory_Proxy" (ByVal sdkVersion As Long, ByRef ppIWICImagingFactory As LongPtr) As Long
Private Declare Function CreateWICBitmap Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateBitmap_Proxy" (ByVal pIWICImagingFactory As LongPtr, ByVal uiWidth As Long, ByVal uiHeight As Long, ByRef PixelFormat As GUID, ByVal eOption As Long, ByRef ppIWICBitmap As LongPtr) As Long
Private Declare Function CreateWICDecoderFromFilename Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateDecoderFromFilename_Proxy" (ByVal pFactory As LongPtr, ByVal wzFilename As LongPtr, ByVal pguidVendor As LongPtr, ByVal dwDesiredAccess As Long, ByVal metadataOptions As Long, ByRef ppIDecoder As LongPtr) As Long
Private Declare Function GetWICFrameCount Lib "Windowscodecs.dll" Alias "IWICBitmapDecoder_GetFrameCount_Proxy" (ByVal pIWICDecoder As LongPtr, ByRef pCount As Long) As Long
Private Declare Function GetWICFrame Lib "Windowscodecs.dll" Alias "IWICBitmapDecoder_GetFrame_Proxy" (ByVal pIWICDecoder As LongPtr, ByVal index As Long, ByRef ppIBitmapFrame As LongPtr) As Long
Private Declare Function ConvertWICBitmap Lib "Windowscodecs.dll" Alias "WICConvertBitmapSource" (ByRef dstFormat As GUID, ByVal pISrc As LongPtr, ByRef ppIDst As LongPtr) As Long
Private Declare Function CreateWICBitmapFromSource Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateBitmapFromSource_Proxy" (ByVal pFactory As LongPtr, ByVal pIBitmapSource As LongPtr, ByVal eOption As Long, ByRef ppIBitmap As LongPtr) As Long
Private Declare Function CreateBitmapFromHBITMAP Lib "Windowscodecs.dll" Alias "IWICImagingFactory_CreateBitmapFromHBITMAP_Proxy" (ByVal pFactory As LongPtr, ByVal hbitmap As LongPtr, ByVal hPalette As LongPtr, ByVal eOption As Long, ByRef ppIBitmap As LongPtr) As Long
Private Declare Function GetWICBitmapSourceSize Lib "Windowscodecs.dll" Alias "IWICBitmapSource_GetSize_Proxy" (ByVal pIWICBitmapSource As LongPtr, ByRef puiWidth As Long, ByRef puiHeight As Long) As Long
Private Declare Function LockWICBitmap Lib "Windowscodecs.dll" Alias "IWICBitmap_Lock_Proxy" (ByVal pIBitmap As LongPtr, ByRef prcLock As WICRect, ByVal lockFlags As Long, ByRef ppILock As LongPtr) As Long
Private Declare Function GetWICLockDataPointer Lib "Windowscodecs.dll" Alias "IWICBitmapLock_GetDataPointer_STA_Proxy" (ByVal pILock As LongPtr, ByRef pcbBufferSize As Long, ByRef ppbData As LongPtr) As Long
#End If
Private Enum D2D1_DEBUG_LEVEL
D2D1_DEBUG_LEVEL_NONE = 0&
End Enum
Private Enum D2D1_GAUSSIANBLUR_PROP
D2D1_GAUSSIANBLUR_PROP_STANDARD_DEVIATION = 0&
D2D1_GAUSSIANBLUR_PROP_OPTIMIZATION = 1&
D2D1_GAUSSIANBLUR_PROP_BORDER_MODE = 2&
End Enum
Private Enum D2D1_PROPERTY_TYPE
D2D1_PROPERTY_TYPE_BOOL = 2&
D2D1_PROPERTY_TYPE_FLOAT = 5&
D2D1_PROPERTY_TYPE_VECTOR2 = 6&
D2D1_PROPERTY_TYPE_IUNKNOWN = 10&
D2D1_PROPERTY_TYPE_ENUM = 11&
End Enum
Private Enum D2D1_BORDER_MODE
D2D1_BORDER_MODE_SOFT = 0&
D2D1_BORDER_MODE_HARD = 1&
End Enum
Private Enum D2D1_BITMAPSOURCE_PROP
D2D1_BITMAPSOURCE_PROP_WIC_BITMAP_SOURCE = 0&
D2D1_BITMAPSOURCE_PROP_SCALE = 1&
D2D1_BITMAPSOURCE_PROP_INTERPOLATION_MODE = 2&
D2D1_BITMAPSOURCE_PROP_ENABLE_DPI_CORRECTION = 3&
D2D1_BITMAPSOURCE_PROP_ALPHA_MODE = 4&
D2D1_BITMAPSOURCE_PROP_ORIENTATION = 5&
End Enum
Private Enum vtb_Interfaces
' IUnknown
QueryInterface = 0&
vtblFucRelease = 2&
' ID2D1Factory
CreateWicBitmapRenderTarget = 13&
' ID2D1DeviceContext2
Clear = 47&
BeginDraw = 48&
EndDraw = 49&
CreateEffect = 63&
GetImageLocalBounds = 70&
DrawImage = 83&
' ID2D1Effect
SetValue = 9&
SetInput = 14&
GetOutput = 18&
End Enum
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0& To 7&) As Byte
End Type
Private Type D2D1_FACTORY_OPTIONS
eDebugLevel As D2D1_DEBUG_LEVEL
End Type
Private Type WICRect
x As Long
Y As Long
Width As Long
Height As Long
End Type
Private Type D2D1_RECT_F
left As Single
top As Single
right As Single
bottom As Single
End Type
Private Type D2D1_POINT_2F
x As Single
Y As Single
End Type
Private Type D2D1_PIXEL_FORMAT
eDxgiFormat As Long
eAlphaMode As Long
End Type
Private Type D2D1_RENDER_TARGET_PROPERTIES
eTargetType As Long
tPixelFormat As D2D1_PIXEL_FORMAT
sngDpiX As Single
sngDpiY As Single
eTargetUsage As Long
eMinFeatureLevel As Long
End Type
Private Type D2D1_VECTOR_2F
x As Single
Y As Single
End Type
Private Type D2D1_COLOR_F
r As Single
g As Single
b As Single
a As Single
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
PicType As Long
hgdiObj As LongPtr
hPalOrXYExt As LongPtr
End Type
Private Const D2D1_BITMAPSOURCE_ORIENTATION_DEFAULT = 1&
Private Const D2D1_INTERPOLATION_MODE_LINEAR = 1&
Private Const WICBitmapLockRead = 1&
Private Const D2D1_GAUSSIANBLUR_OPTIMIZATION_BALANCED = 1&
Private Const D2D1_BITMAPSOURCE_ALPHA_MODE_PREMULTIPLIED = 1&
Private Const D2D1_BITMAPSOURCE_INTERPOLATION_MODE_FANT = 6&
Private Const D2D1_ALPHA_MODE_PREMULTIPLIED = 1&
Private m_pIWICImagingFactory As LongPtr
Private m_pID2D1Factory As LongPtr
Private m_pIWICBitmap As LongPtr
Private m_pID2D1RenderTarget As LongPtr
Private m_pID2D1DeviceContext2 As LongPtr
Private pID2D1Image As LongPtr
Private pID2D1ImageEffect As LongPtr
' _____________________________________________ Public Routines _______________________________________________________
Public Function BlurImageFromFile( _
ByVal FileName As String, _
Optional ByVal ScaleX As Single = 1&, _
Optional ByVal ScaleY As Single = 1&, _
Optional ByVal BlurRadius As Single = 3& _
) As StdPicture
Dim oStdPic As StdPicture
If Len(Dir(FileName)) = 0& Then
MsgBox "Invalid File.": GoTo Xit
End If
If Initialize = False Then
MsgBox "Unable to create a WIC factory.": GoTo Xit
End If
pID2D1Image = ImageFileToD2D1Image(FileName, NewVector_2F(ScaleX, ScaleY))
If pID2D1Image = 0 Then
MsgBox "Unable to create WICBitmap.": GoTo Xit
End If
pID2D1ImageEffect = CreateD2D1GaussianBlurEffect(pID2D1Image, BlurRadius, D2D1_GAUSSIANBLUR_OPTIMIZATION_BALANCED, D2D1_BORDER_MODE_HARD)
If pID2D1Image = 0 Then
MsgBox "Unable to create Blur Effect.": GoTo Xit
End If
Set oStdPic = D2D1ImageToPicture(pID2D1ImageEffect, NewColor_F)
If oStdPic Is Nothing Then
MsgBox "Unable to create vb StandardPicture.": GoTo Xit
End If
Set BlurImageFromFile = oStdPic
Xit:
Call ReleaseInterface(pID2D1Image)
Call Terminate
End Function
Public Function BlurImageFromImageHandle( _
ByVal ImageHandle As LongPtr, _
Optional ByVal ScaleX As Single = 1&, _
Optional ByVal ScaleY As Single = 1&, _
Optional ByVal BlurRadius As Single = 3& _
) As StdPicture
Dim oStdPic As StdPicture
If ImageHandle = 0 Then
MsgBox "Invalid image handle.": GoTo Xit
End If
If Initialize = False Then
MsgBox "Unable to create a WIC factory.": GoTo Xit
End If
pID2D1Image = ImageHandleToD2D1Image(ImageHandle, NewVector_2F(ScaleX, ScaleY))
If pID2D1Image = 0 Then
MsgBox "Unable to create WICBitmap.": GoTo Xit
End If
pID2D1ImageEffect = CreateD2D1GaussianBlurEffect(pID2D1Image, BlurRadius, D2D1_GAUSSIANBLUR_OPTIMIZATION_BALANCED, D2D1_BORDER_MODE_HARD)
If pID2D1Image = 0 Then
MsgBox "Unable to create Blur Effect.": GoTo Xit
End If
Set oStdPic = D2D1ImageToPicture(pID2D1ImageEffect, NewColor_F)
If oStdPic Is Nothing Then
MsgBox "Unable to create vb StandardPicture.": GoTo Xit
End If
Set BlurImageFromImageHandle = oStdPic
Xit:
Call ReleaseInterface(pID2D1Image)
Call Terminate
End Function
' _____________________________________________ Private Routines _______________________________________________________
Private Function Initialize() As Boolean
Const IID_ID2D1DeviceContext2 As String = "{394ea6a3-0c34-4321-950b-6ca20f0be6c7}"
Const GUID_WICPixelFormat32bppPBGRA As String = "{6fddc324-4e03-4bfe-b185-3d77768dc910}"
Const IID_ID2D1Factory As String = "{06152247-6f50-465a-9245-118bfd3b6007}"
Const S_OK = 0&, WICBitmapCacheOnDemand = 1&, WINCODEC_SDK_VERSION2 = &H237&, DXGI_FORMAT_B8G8R8A8_UNORM = 87&
Const D2D1_FACTORY_TYPE_SINGLE_THREADED = 0&
Dim bolRet As Boolean
Dim tD2D1_FACTORY_OPTIONS As D2D1_FACTORY_OPTIONS
Dim tD2D1_RENDER_TARGET_PROPERTIES As D2D1_RENDER_TARGET_PROPERTIES
bolRet = False
' create a WIC factory
If CreateWICFactory(WINCODEC_SDK_VERSION2, m_pIWICImagingFactory) = S_OK Then
tD2D1_FACTORY_OPTIONS.eDebugLevel = D2D1_DEBUG_LEVEL_NONE
'create a D2D1 factory
' Creates a factory object that can be used to create Direct2D resources
If CreateD2D1Factory(D2D1_FACTORY_TYPE_SINGLE_THREADED, _
Str2Guid(IID_ID2D1Factory), tD2D1_FACTORY_OPTIONS, _
m_pID2D1Factory) = S_OK Then
' create a WIC bitmap
' Fonction proxy pour la méthode CreateBitmap .
If CreateWICBitmap(m_pIWICImagingFactory, 1&, 1&, _
Str2Guid(GUID_WICPixelFormat32bppPBGRA), _
WICBitmapCacheOnDemand, m_pIWICBitmap) = S_OK Then
With tD2D1_RENDER_TARGET_PROPERTIES
.tPixelFormat.eDxgiFormat = DXGI_FORMAT_B8G8R8A8_UNORM
.tPixelFormat.eAlphaMode = D2D1_ALPHA_MODE_PREMULTIPLIED
End With
If vtblCall(m_pID2D1Factory, CreateWicBitmapRenderTarget, m_pIWICBitmap, _
VarPtr(tD2D1_RENDER_TARGET_PROPERTIES), VarPtr(m_pID2D1RenderTarget)) = S_OK Then
' Create a D2D1 DeviceContext from the D2D1 RenderTarget
If vtblCall(m_pID2D1RenderTarget, QueryInterface, _
VarPtr(Str2Guid(IID_ID2D1DeviceContext2)), _
VarPtr(m_pID2D1DeviceContext2)) = S_OK Then
bolRet = True
End If
End If
End If
End If
End If
Initialize = bolRet
End Function
Private Sub Terminate()
If m_pID2D1DeviceContext2 <> 0& Then Call ReleaseInterface(m_pID2D1DeviceContext2)
If m_pID2D1RenderTarget <> 0& Then Call ReleaseInterface(m_pID2D1RenderTarget)
If m_pIWICBitmap <> 0& Then Call ReleaseInterface(m_pIWICBitmap)
If m_pID2D1Factory <> 0& Then Call ReleaseInterface(m_pID2D1Factory)
If m_pIWICImagingFactory <> 0& Then Call ReleaseInterface(m_pIWICImagingFactory)
End Sub
Private Function ImageHandleToD2D1Image( _
ByVal hbitmap As LongPtr, _
ByRef ScaleBitmap As D2D1_VECTOR_2F, _
Optional ByVal orientation As Long = D2D1_BITMAPSOURCE_ORIENTATION_DEFAULT, _
Optional ByVal interpolationMode As Long = D2D1_BITMAPSOURCE_INTERPOLATION_MODE_FANT, _
Optional ByVal alphaMode As Long = D2D1_BITMAPSOURCE_ALPHA_MODE_PREMULTIPLIED, _
Optional ByVal enableDpiCorrection As Boolean = False _
) As LongPtr
Dim pIWICBitmap As LongPtr
' there is a picture
If hbitmap Then
' Limitation
If ScaleBitmap.x < 0.01 Then ScaleBitmap.x = 0.01
If ScaleBitmap.Y < 0.01 Then ScaleBitmap.Y = 0.01
pIWICBitmap = ImageHandleToWICBitmap(hbitmap)
If pIWICBitmap <> 0& Then
' converts a WIC bitmap to a D2D1 image
ImageHandleToD2D1Image = CreateD2D1BitmapSourceEffect(pIWICBitmap, _
ScaleBitmap, orientation, interpolationMode, alphaMode, enableDpiCorrection)
Call ReleaseInterface(pIWICBitmap)
End If
End If
End Function
Private Function ImageHandleToWICBitmap(ByVal hbitmap As LongPtr) As LongPtr
Const IMAGE_BITMAP = 0&: Const LR_COPYRETURNORG = &H4
Dim hPtr As LongPtr
'a bmp handle exists
If hbitmap Then
hPtr = CopyImage(hbitmap, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CreateBitmapFromHBITMAP(m_pIWICImagingFactory, hPtr, NULL_PTR, _
D2D1_BITMAPSOURCE_ALPHA_MODE_PREMULTIPLIED, ImageHandleToWICBitmap)
Call DeleteObject(hPtr)
End If
End Function
Private Function ImageFileToWICBitmap(ByVal FileName As String) As LongPtr
Const GUID_WICPixelFormat32bppPBGRA As String = "{6fddc324-4e03-4bfe-b185-3d77768dc910}"
Const S_OK = 0&, WICBitmapCacheOnDemand = 1&, GENERIC_READ = &H80000000, WICDecodeMetadataCacheOnDemand = 0&
Dim lngFrameCount As Long
Dim pIWICBitmap As LongPtr
Dim pIWICBitmapDecoder As LongPtr
Dim pIWICBitmapFrameDecode As LongPtr
' a file exists
If Len(FileName) <> 0& Then
' create a WIC BitmapDecoder from the file
If CreateWICDecoderFromFilename(m_pIWICImagingFactory, StrPtr(FileName), NULL_PTR, _
GENERIC_READ, WICDecodeMetadataCacheOnDemand, pIWICBitmapDecoder) = S_OK Then
' Determine the number of frames
If GetWICFrameCount(pIWICBitmapDecoder, lngFrameCount) = S_OK Then
' at least one frame exists
If lngFrameCount > 0 Then
' load first frame
If GetWICFrame(pIWICBitmapDecoder, 0&, pIWICBitmapFrameDecode) = S_OK Then
' Convert frame to 32bppPBGRA format -> WIC bitmap
If ConvertWICBitmap(Str2Guid(GUID_WICPixelFormat32bppPBGRA), _
pIWICBitmapFrameDecode, pIWICBitmap) = S_OK Then
Call CreateWICBitmapFromSource(m_pIWICImagingFactory, _
pIWICBitmap, WICBitmapCacheOnDemand, ImageFileToWICBitmap)
Call ReleaseInterface(pIWICBitmap)
End If
' Delete WIC BitmapFrameDecode
Call ReleaseInterface(pIWICBitmapFrameDecode)
End If
End If
End If
' Delete WIC BitmapDecoder
Call ReleaseInterface(pIWICBitmapDecoder)
End If
End If
End Function
Private Function ImageFileToD2D1Image( _
ByVal FileName As String, _
ByRef ScaleBitmap As D2D1_VECTOR_2F, _
Optional ByVal orientation As Long = D2D1_BITMAPSOURCE_ORIENTATION_DEFAULT, _
Optional ByVal interpolationMode As Long = D2D1_BITMAPSOURCE_INTERPOLATION_MODE_FANT, _
Optional ByVal alphaMode As Long = D2D1_BITMAPSOURCE_ALPHA_MODE_PREMULTIPLIED, _
Optional ByVal enableDpiCorrection As Boolean = False _
) As LongPtr
Dim bytData() As Byte
Dim pIWICBitmap As LongPtr
Dim pID2D1Effect As LongPtr
' there is a picture
If Len(FileName) <> 0& Then
' Limitation
If ScaleBitmap.x < 0.01 Then ScaleBitmap.x = 0.01
If ScaleBitmap.Y < 0.01 Then ScaleBitmap.Y = 0.01
pIWICBitmap = ImageFileToWICBitmap(FileName)
If pIWICBitmap <> NULL_PTR Then
' converts a WIC bitmap to a D2D1 image
ImageFileToD2D1Image = CreateD2D1BitmapSourceEffect(pIWICBitmap, _
ScaleBitmap, orientation, interpolationMode, alphaMode, enableDpiCorrection)
Call ReleaseInterface(pIWICBitmap)
End If
End If
End Function
Private Function CreateD2D1GaussianBlurEffect( _
ByVal pID2D1Image As LongPtr, _
Optional ByVal StandardDeviation As Single = 3, _
Optional ByVal optimation As Long = D2D1_GAUSSIANBLUR_OPTIMIZATION_BALANCED, _
Optional ByVal borderMode As D2D1_BORDER_MODE = D2D1_BORDER_MODE_SOFT _
) As LongPtr
Const CLSID_D2D1GaussianBlur As String = "{1feb6d69-2fe6-4ac9-8c58-1d7f93e7a6a5}"
Const S_OK = 0&
Dim bytData() As Byte
Dim pID2D1Effect As LongPtr
If pID2D1Image <> NULL_PTR Then
If StandardDeviation < 0 Then StandardDeviation = 0
If vtblCall(m_pID2D1DeviceContext2, CreateEffect, _
VarPtr(Str2Guid(CLSID_D2D1GaussianBlur)), _
VarPtr(pID2D1Effect)) = S_OK Then
Call vtblCall(pID2D1Effect, SetInput, 0&, pID2D1Image, 1&)
bytData = SingleToByteArray(StandardDeviation)
'ID2D1Properties::SetValue
If vtblCall(pID2D1Effect, SetValue, _
D2D1_GAUSSIANBLUR_PROP_STANDARD_DEVIATION, _
D2D1_PROPERTY_TYPE_FLOAT, _
VarPtr(bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = LongToByteArray(optimation)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_GAUSSIANBLUR_PROP_OPTIMIZATION, _
D2D1_PROPERTY_TYPE_ENUM, _
VarPtr(bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = LongToByteArray(borderMode)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_GAUSSIANBLUR_PROP_BORDER_MODE, _
D2D1_PROPERTY_TYPE.D2D1_PROPERTY_TYPE_ENUM, _
VarPtr(bytData(0)), UBound(bytData) + 1) = S_OK Then
Call vtblCall(pID2D1Effect, GetOutput, VarPtr(CreateD2D1GaussianBlurEffect))
End If
End If
End If
Call ReleaseInterface(pID2D1Effect)
End If
End If
End Function
Private Function CreateD2D1BitmapSourceEffect( _
ByVal pIWICBitmap As LongPtr, _
ByRef ScaleBitmap As D2D1_VECTOR_2F, _
Optional ByVal orientation As Long = D2D1_BITMAPSOURCE_ORIENTATION_DEFAULT, _
Optional ByVal interpolationMode As Long = D2D1_BITMAPSOURCE_INTERPOLATION_MODE_FANT, _
Optional ByVal alphaMode As Long = D2D1_BITMAPSOURCE_ALPHA_MODE_PREMULTIPLIED, _
Optional ByVal enableDpiCorrection As Boolean = False _
) As LongPtr
Const CLSID_D2D1BitmapSource As String = "{5fb6c24d-c6dd-4231-9404-50f4d5c3252d}"
Const S_OK = 0&
Dim bytData() As Byte
Dim pID2D1Effect As LongPtr
If pIWICBitmap <> 0& Then
If ScaleBitmap.x < 0.01 Then ScaleBitmap.x = 0.01
If ScaleBitmap.Y < 0.01 Then ScaleBitmap.Y = 0.01
If vtblCall(m_pID2D1DeviceContext2, CreateEffect, _
VarPtr(Str2Guid(CLSID_D2D1BitmapSource)), _
VarPtr(pID2D1Effect)) = S_OK Then
bytData = LongToByteArray64(pIWICBitmap)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_BITMAPSOURCE_PROP.D2D1_BITMAPSOURCE_PROP_WIC_BITMAP_SOURCE, _
D2D1_PROPERTY_TYPE_IUNKNOWN, VarPtr( _
bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = Vector2ToByteArray(ScaleBitmap)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_BITMAPSOURCE_PROP.D2D1_BITMAPSOURCE_PROP_SCALE, _
D2D1_PROPERTY_TYPE.D2D1_PROPERTY_TYPE_VECTOR2, VarPtr( _
bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = LongToByteArray(interpolationMode)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_BITMAPSOURCE_PROP.D2D1_BITMAPSOURCE_PROP_INTERPOLATION_MODE, _
D2D1_PROPERTY_TYPE.D2D1_PROPERTY_TYPE_ENUM, VarPtr( _
bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = BooleanToByteArray(enableDpiCorrection)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_BITMAPSOURCE_PROP.D2D1_BITMAPSOURCE_PROP_ENABLE_DPI_CORRECTION, _
D2D1_PROPERTY_TYPE.D2D1_PROPERTY_TYPE_BOOL, _
VarPtr(bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = LongToByteArray(alphaMode)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_BITMAPSOURCE_PROP.D2D1_BITMAPSOURCE_PROP_ALPHA_MODE, _
D2D1_PROPERTY_TYPE.D2D1_PROPERTY_TYPE_ENUM, _
VarPtr(bytData(0)), UBound(bytData) + 1) = S_OK Then
bytData = LongToByteArray(orientation)
If vtblCall(pID2D1Effect, SetValue, _
D2D1_BITMAPSOURCE_PROP.D2D1_BITMAPSOURCE_PROP_ORIENTATION, _
D2D1_PROPERTY_TYPE.D2D1_PROPERTY_TYPE_ENUM, _
VarPtr(bytData(0)), UBound(bytData) + 1) = S_OK Then
Call vtblCall(pID2D1Effect, GetOutput, VarPtr(CreateD2D1BitmapSourceEffect))
End If
End If
End If
End If
End If
End If
Call ReleaseInterface(pID2D1Effect)
End If
End If
End Function
Private Function D2D1ImageToPicture(ByVal pID2D1Image As LongPtr, ByRef backColor As D2D1_COLOR_F) As StdPicture
Const IID_ID2D1DeviceContext2 As String = "{394ea6a3-0c34-4321-950b-6ca20f0be6c7}"
Const GUID_WICPixelFormat32bppPBGRA As String = "{6fddc324-4e03-4bfe-b185-3d77768dc910}"
Const S_OK = 0&, WICBitmapCacheOnDemand = 1&, D2D1_COMPOSITE_MODE_SOURCE_OVER = 0&, DXGI_FORMAT_B8G8R8A8_UNORM = 87&
Dim lngWidth As Long
Dim lngHeight As Long
Dim pIWICBitmap As LongPtr
Dim pID2D1RenderTarget As LongPtr
Dim pID2D1DeviceContext As LongPtr
Dim tD2D1_RECT_F As D2D1_RECT_F
Dim tD2D1_POINT_2F As D2D1_POINT_2F
Dim tD2D1_RENDER_TARGET_PROPERTIES As D2D1_RENDER_TARGET_PROPERTIES
' a D2D1 image is present
If pID2D1Image <> NULL_PTR Then
' Determine dimensions of the D2D1 image
If vtblCall(m_pID2D1DeviceContext2, GetImageLocalBounds, _
pID2D1Image, VarPtr(tD2D1_RECT_F)) = S_OK Then
' We limit the maximum size here
If tD2D1_RECT_F.left < -2.147483E+09! Then tD2D1_RECT_F.left = -4096
If tD2D1_RECT_F.top < -2.147483E+09! Then tD2D1_RECT_F.top = -4096
If tD2D1_RECT_F.right > 2.147483E+09! Then tD2D1_RECT_F.right = 4096
If tD2D1_RECT_F.bottom > 2.147483E+09! Then tD2D1_RECT_F.bottom = 4096
' Save height and width
lngWidth = CLng(tD2D1_RECT_F.right)
lngHeight = CLng(tD2D1_RECT_F.bottom)
' Create a WIC bitmap in appropriate dimensions
If CreateWICBitmap(m_pIWICImagingFactory, lngWidth, lngHeight, _
Str2Guid(GUID_WICPixelFormat32bppPBGRA), _
WICBitmapCacheOnDemand, pIWICBitmap) = S_OK Then
With tD2D1_RENDER_TARGET_PROPERTIES
.tPixelFormat.eDxgiFormat = DXGI_FORMAT_B8G8R8A8_UNORM
.tPixelFormat.eAlphaMode = D2D1_ALPHA_MODE_PREMULTIPLIED
End With
' Create a D2D1 RenderTarget from the WIC bitmap
If vtblCall(m_pID2D1Factory, CreateWicBitmapRenderTarget, _
pIWICBitmap, VarPtr(tD2D1_RENDER_TARGET_PROPERTIES), _
VarPtr(pID2D1RenderTarget)) = S_OK Then
' Create a D2D1 DeviceContext from the D2D1 RenderTarget
If vtblCall(pID2D1RenderTarget, QueryInterface, _
VarPtr(Str2Guid(IID_ID2D1DeviceContext2)), _
VarPtr(pID2D1DeviceContext)) = S_OK Then
' start drawing into the D2D1 DeviceContext
Call vtblCall(pID2D1DeviceContext, BeginDraw)
' Erase background with one color
Call vtblCall(pID2D1DeviceContext, Clear, VarPtr(backColor))
With tD2D1_POINT_2F
.x = tD2D1_RECT_F.left
.Y = tD2D1_RECT_F.top
End With
' draws the D2D1 image into the D2D1 DeviceContext
Call vtblCall(pID2D1DeviceContext, DrawImage, pID2D1Image, _
VarPtr(tD2D1_POINT_2F), VarPtr(tD2D1_RECT_F), _
D2D1_INTERPOLATION_MODE_LINEAR, _
D2D1_COMPOSITE_MODE_SOURCE_OVER)
' finish drawing into the D2D1 DeviceContext
Call vtblCall(pID2D1DeviceContext, EndDraw, 0, 0)
' Delete D2D1 DeviceContext
Call ReleaseInterface(pID2D1DeviceContext)
End If
' Delete D2D1 RenderTarget
Call ReleaseInterface(pID2D1RenderTarget)
End If
Set D2D1ImageToPicture = WICBitmapToPicture(pIWICBitmap)
' Delete WIC bitmap
Call ReleaseInterface(pIWICBitmap)
End If
End If
End If
End Function
Private Function WICBitmapToPicture(ByVal pIWICBitmap As LongPtr) As StdPicture
Const IID_IPicture As String = "{7bf80980-bf32-101a-8bbb-00aa00300cab}"
Const S_OK = 0&
Dim hbitmap As LongPtr
Dim lngWidth As Long
Dim lngHeight As Long
Dim lngBuffSize As Long
Dim pData As LongPtr
Dim pIWICBitmapLock As LongPtr
Dim tWICRect As WICRect
Dim tPICTDESC As PICTDESC
Dim tBITMAPINFO As BITMAPINFO
If pIWICBitmap <> 0& Then
If GetWICBitmapSourceSize(pIWICBitmap, lngWidth, lngHeight) = S_OK Then
With tWICRect
.x = 0&
.Y = 0&
.Width = lngWidth
.Height = lngHeight
End With
' LockBits
If LockWICBitmap(pIWICBitmap, tWICRect, _
WICBitmapLockRead, pIWICBitmapLock) = S_OK Then
' Get pointer to the image data
If GetWICLockDataPointer(pIWICBitmapLock, _
lngBuffSize, pData) = S_OK Then
With tBITMAPINFO
.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader)
.bmiHeader.biWidth = lngWidth
.bmiHeader.biHeight = -lngHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = 32
End With
' create a DIB
hbitmap = CreateDIBSection(NULL_PTR, tBITMAPINFO, 0&, NULL_PTR, NULL_PTR, 0&)
' a DIB is available
If hbitmap <> 0& Then
' Copy image data to the DIB
If SetDIBits(0&, hbitmap, 0&, lngHeight, pData, _
tBITMAPINFO, 0&) = lngHeight Then
With tPICTDESC
.cbSizeOfStruct = Len(tPICTDESC)
.PicType = 1
.hgdiObj = hbitmap
End With
' create a StdPicture from the DIB
Call OleCreatePictureIndirect(tPICTDESC, _
Str2Guid(IID_IPicture), 1&, WICBitmapToPicture)
End If
End If
End If
Call ReleaseInterface(pIWICBitmapLock)
End If
End If
End If
End Function
' __________________________________________________helper routines ___________________________________________________________
Private Function Vector2ToByteArray(ByRef value As D2D1_VECTOR_2F) As Byte()
Dim bytData() As Byte
Dim lngDataSize As Long
lngDataSize = LenB(value)
ReDim bytData(lngDataSize - 1)
Call CopyMemory(bytData(0), value, lngDataSize)
Vector2ToByteArray = bytData
End Function
Private Function BooleanToByteArray(ByVal value As Boolean) As Byte()
Dim bytData() As Byte
Dim lngBool As Long
Dim lngDataSize As Long
lngBool = Abs(value)
lngDataSize = LenB(lngBool)
ReDim bytData(lngDataSize - 1)
Call CopyMemory(bytData(0), lngBool, lngDataSize)
BooleanToByteArray = bytData
End Function
Private Function SingleToByteArray(ByVal value As Single) As Byte()
Dim bytData() As Byte
Dim lngDataSize As Long
lngDataSize = LenB(value)
ReDim bytData(lngDataSize - 1)
Call CopyMemory(bytData(0), value, lngDataSize)
SingleToByteArray = bytData
End Function
Private Function LongToByteArray(ByVal value As Long) As Byte()
Dim bytData() As Byte
Dim lngDataSize As Long
lngDataSize = LenB(value)
ReDim bytData(lngDataSize - 1&)
Call CopyMemory(bytData(0), value, lngDataSize)
LongToByteArray = bytData
End Function
'
Private Function LongToByteArray64(ByVal value As LongPtr) As Byte()
Dim bytData() As Byte
Dim lngDataSize As Long
lngDataSize = LenB(value)
ReDim bytData(lngDataSize - 1&)
Call CopyMemory(bytData(0), value, lngDataSize)
LongToByteArray64 = bytData
End Function
Private Function NewVector_2F(Optional ByVal x As Single = 0, Optional ByVal Y As Single = 0) As D2D1_VECTOR_2F
With NewVector_2F
.x = x
.Y = Y
End With
End Function
Private Function NewColor_F( _
Optional ByVal a As Single = 0, _
Optional ByVal r As Single = 0, _
Optional ByVal g As Single = 0, _
Optional ByVal b As Single = 0 _
) As D2D1_COLOR_F
With NewColor_F
.a = a
.r = r
.g = g
.b = b
End With
End Function
Private Function Str2Guid(ByVal str As String) As GUID
Call CLSIDFromString(StrPtr(str), Str2Guid)
End Function
Private Sub ReleaseInterface(ByRef pInterface As LongPtr)
Const CC_STDCALL = 4&, S_OK = 0&
Dim varRet As Variant
' there is a pointer to an interface
If pInterface <> NULL_PTR Then
' Call the Release function of the interface
If DispCallFunc(pInterface, vtblFucRelease * PTR_LEN, CC_STDCALL, _
vbEmpty, 0&, NULL_PTR, NULL_PTR, varRet) = S_OK Then
pInterface = NULL_PTR
End If
End If
End Sub
Private Function vtblCall( _
ByVal pInterface As LongPtr, _
ByVal eInterfaceFunction As vtb_Interfaces, _
ParamArray arrParam() _
) As Variant
' there is a pointer to an interface
If pInterface <> 0& Then
' Call OleInvoke
vtblCall = OleInvoke(pInterface, eInterfaceFunction, arrParam)
End If
End Function
Private Function OleInvoke( _
ByVal pInterface As LongPtr, _
ByVal lIndex As Long, _
ParamArray arrParam() _
) As Variant
Const CC_STDCALL = 4&, S_OK = 0&
Dim lngItem As Long
Dim lngCount As Long
Dim varRet As Variant
Dim varParam As Variant
Dim olePtr(10&) As LongPtr
Dim oleTyp(10&) As Integer
' there is a pointer to an interface
If pInterface <> 0& Then
'only when calling the interface function
' Parameters are also available.
If UBound(arrParam) >= 0 Then
' ParamArray to Variant
varParam = arrParam
' the variant is an array
If IsArray(varParam) Then varParam = varParam(0)
' Number of parameters
lngCount = UBound(varParam)
' go through all parameters
For lngItem = 0 To lngCount
' Type of parameter
oleTyp(lngItem) = VarType(varParam(lngItem))
' Pointer to the parameter
olePtr(lngItem) = VarPtr(varParam(lngItem))
Next
End If
' Execute function of the interface
If DispCallFunc(pInterface, lIndex * PTR_LEN, CC_STDCALL, vbLong, _
lngItem, VarPtr(oleTyp(0)), VarPtr(olePtr(0)), varRet) <> S_OK Then
Debug.Print "Error calling interface function!"""
End If
End If
OleInvoke = varRet
End Function2- Code usage example:
VBA Code:
Option Explicit
Private Sub CommandButton1_Click()
Image1.Picture = bas_Blur.BlurImageFromImageHandle(Image2.Picture.Handle)
End Sub
Private Sub CommandButton2_Click()
Image3.Picture = bas_Blur.BlurImageFromImageHandle(Image4.Picture.Handle, , , 6)
End Sub
