[VB6] Blur effect on GDI+ bitmaps

Description

This module might come handy for implementing drop shadows or similar effects. Based on the original Gaussian blur implementation by an IIR (Infininte Impulse Response) in Tanner Helland's PhotoDemon but uses ASM/SSE thunks for the array handling which speeds the processing ~20x times (in VBIDE).

Performance

On my i7-4770 @ 3.50GHz a 1920x1200 JPEG (24-bit, only RGB channels, ~10x larger than 500x500 image) is blurred with radius 25 px for 269 ms (~0.3 sec) when compiled w/ no optimizations and about the same in VBIDE. For comparison you can check out some measurements of IIR filters and other Gaussian blur implementations in this post by Tanner.

With IIR implementation blur radius does not affect performance as the number of steps performed is invariant to the radius value. IIR also allows for floating-point values to be used for the blur radii. The constant NUM_ITERS in pvBlurChannel greatly affects performance vs quality ratio of the filter though, so it's possible that GIMP and other popular graphics applications use 5 or more iterations, which can explain this module's better performance.

Sample usage

Just call the only public function BlurBitmap passing the GDI+ bitmap, blur radius (floating-point in pixels) and optionally a bitmask with ARGB channels to be processed like this:

If Not BlurBitmap(hBitmap, 4.5) Then GoTo QH

Source code

thinBasic Code:

' mdBlurBitmap.bas
Option Explicit
DefObj A-Z
 
'--- for VirtualProtect
Private Const PAGE_EXECUTE_READWRITE        As Long = &H40
Private Const MEM_COMMIT                    As Long = &H1000
'--- for CryptStringToBinary
Private Const CRYPT_STRING_BASE64           As Long = 1
'--- for gdi+
Private Const ImageLockModeRead         As Long = &H1
Private Const ImageLockModeWrite        As Long = &H2
Private Const PixelFormat32bppARGB      As Long = &H26200A
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
'--- gdi+
Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal hBitmap As Long, lpRect As Any, ByVal lFlags As Long, ByVal lPixelFormat As Long, uLockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal hBitmap As Long, uLockedBitmapData As BitmapData) As Long
 
Private Type BitmapData
    Width               As Long
    Height              As Long
    Stride              As Long
    PixelFormat         As Long
    Scan0               As Long
    Reserved            As Long
End Type
 
Public Function BlurBitmap( _
            ByVal hBitmap As Long, _
            ByVal sngRadius As Single, _
            Optional ByVal AffectChannels As Long = 15) As Boolean
    Dim uData           As BitmapData
    Dim dblBuffer()     As Double
 
    If GdipBitmapLockBits(hBitmap, ByVal 0, ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppARGB, uData) <> 0 Then
        GoTo QH
    End If
    ReDim dblBuffer(0 To uData.Width - 1, 0 To uData.Height - 1) As Double
    If (AffectChannels And 1) <> 0 Then
        If Not pvBlurChannel(uData.Scan0, uData.Stride \ 4, 0, 0, uData.Width, uData.Height, sngRadius, 0, dblBuffer) Then
            GoTo QH
        End If
    End If
    If (AffectChannels And 2) <> 0 Then
        If Not pvBlurChannel(uData.Scan0, uData.Stride \ 4, 0, 0, uData.Width, uData.Height, sngRadius, 1, dblBuffer) Then
            GoTo QH
        End If
    End If
    If (AffectChannels And 4) <> 0 Then
        If Not pvBlurChannel(uData.Scan0, uData.Stride \ 4, 0, 0, uData.Width, uData.Height, sngRadius, 2, dblBuffer) Then
            GoTo QH
        End If
    End If
    If (AffectChannels And 8) <> 0 Then
        If Not pvBlurChannel(uData.Scan0, uData.Stride \ 4, 0, 0, uData.Width, uData.Height, sngRadius, 3, dblBuffer) Then
            GoTo QH
        End If
    End If
    '--- success
    BlurBitmap = True
QH:
    If uData.Scan0 <> 0 Then
        Call GdipBitmapUnlockBits(hBitmap, uData)
    End If
End Function
 
Private Function pvBlurChannel( _
            ByVal lpBits As Long, _
            ByVal lStride As Long, _
            ByVal lLeft As Long, _
            ByVal lTop As Long, _
            ByVal lWidth As Long, _
            ByVal lHeight As Long, _
            ByVal dblRadius As Double, _
            ByVal lChannel As Long, _
            dblBuffer() As Double) As Boolean
'--- Gaussian blur filter, using an IIR (Infininte Impulse Response) approach
'--- based on [url]https://github.com/tannerhelland/PhotoDemon/blob/master/Modules/Filters_ByteArray.bas#L40[/url]
    Const NUM_ITERS     As Long = 3
    Dim lIdx            As Long
    Dim lIter           As Long
    Dim dblTemp         As Double
    Dim dblNu           As Double
    Dim dblBndryScale   As Double
    Dim dblPostScale    As Double
 
    ' Prep some IIR-specific values
    dblTemp = Sqr(-(dblRadius * dblRadius) / (2 * Log(1# / 255#)))
    If dblTemp <= 0 Then
        dblTemp = 0.01
    End If
    dblTemp = dblTemp * (1# + (0.3165 * NUM_ITERS + 0.5695) / ((NUM_ITERS + 0.7818) * (NUM_ITERS + 0.7818)))
    dblTemp = (dblTemp * dblTemp) / (2# * NUM_ITERS)
    dblNu = (1# + 2# * dblTemp - Sqr(1# + 4# * dblTemp)) / (2# * dblTemp)
    dblBndryScale = (1# / (1# - dblNu))
    dblPostScale = ((dblNu / dblTemp) ^ (2# * NUM_ITERS)) * 255#
    ' Copy the contents of the incoming byte array into the double array buffer
    LoadSave dblBuffer(0, 0), 1# / 255#, lpBits + (lTop * lStride + lLeft) * 4 + lChannel, lStride, lWidth, lHeight, 0
    ' Filter horizontally along each row
    For lIdx = 0 To lHeight - 1
        For lIter = 1 To NUM_ITERS
            ProcessRow dblBuffer(0, lIdx), dblBndryScale, dblNu, 1, lWidth
            ProcessRow dblBuffer(lWidth - 1, lIdx), dblBndryScale, dblNu, -1, lWidth
        Next
    Next
    ' Now repeat all the above steps, but filtering vertically along each column, instead
    For lIdx = 0 To lWidth - 1
        For lIter = 1 To NUM_ITERS
            ProcessRow dblBuffer(lIdx, 0), dblBndryScale, dblNu, lWidth, lHeight
            ProcessRow dblBuffer(lIdx, lHeight - 1), dblBndryScale, dblNu, -lWidth, lHeight
        Next
    Next
    ' Apply final post-scaling and copy back to byte array
    LoadSave dblBuffer(0, 0), dblPostScale, lpBits + (lTop * lStride + lLeft) * 4 + lChannel, lStride, lWidth, lHeight, 1
    '--- success
    pvBlurChannel = True
End Function
 
Private Sub LoadSave(dblPtr As Double, ByVal dblScale As Double, ByVal srcPtr As Long, ByVal lStride As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByVal fSave As Long)
    'void __stdcall LoadSave(double *ptr, double scale, unsigned char *src, int stride, int w, int h, int fsave) {
    '    for(int j = 0; j < h; j++, src += 4*(stride - w)) {
    '        for(int i = 0; i < w; i++, src += 4, ptr++) {
    '            if (!fsave)
    '                *ptr = *src * scale;
    '            else {
    '                int v = *ptr * scale;
    '                *src = v > 0xFF ? 0xFF : v < 0 ? 0 : v;
    '            }
    '        }
    '    }
    '}
    Const STR_THUNK     As String = "VYvsU4tdIIXbD46DAAAAi00Yi0UcK8jyDxBNDItVCMHhAlaJTRiLTRSLdRhXi30khcB+VYvwhf91FQ" & _
                                    "+2AWYPbsDzD+bA8g9ZwfIPEQLrKfIPEALyD1nB8g8swD3/AAAAfge4/wAAAOsNhcDHRSAAAAAAD0hF" & _
                                    "IIgBg8EEg8IIg+4BdbOLRRyLdRgDzoPrAXWgX15bXcIgAA=="
    pvPatchThunk AddressOf mdBlurBitmap.LoadSave, STR_THUNK
    LoadSave dblPtr, dblScale, srcPtr, lStride, lWidth, lHeight, fSave
End Sub
 
Private Sub ProcessRow(dblPtr As Double, ByVal dblBndryScale As Double, ByVal dblNu As Double, ByVal lStep As Long, ByVal lSize As Long)
    'void __stdcall ProcessRow(double *ptr, double bndry, double nu, int step, int size) {
    '    double temp = (*ptr *= bndry);
    '    ptr += step;
    '    for(int i = 1; i < size; i++) {
    '        temp = (*ptr += nu * temp);
    '        ptr += step;
    '    }
    '}
    Const STR_THUNK     As String = "VYvsi00Ii0UcVlfyDxABvwEAAADyD1lFDI0UxQAAAACLRSDyDxEBA8o7x3558g8QTRSD+AR+Vo1w+" & _
                                    "8HuAkaNPLUBAAAAZmZmDx+EAAAAAADyD1nB8g9YAfIPEQEDyvIPWcHyD1gB8g8RAQPK8g9ZwfIPWA" & _
                                    "HyDxEBA8ryD1nB8g9YAfIPEQEDyoPuAXXDO/h9FSvH8g9ZwfIPWAHyDxEBA8qD6AF17V9eXcIcAA=="
    pvPatchThunk AddressOf mdBlurBitmap.ProcessRow, STR_THUNK
    ProcessRow dblPtr, dblBndryScale, dblNu, lStep, lSize
End Sub
 
Private Sub pvPatchThunk(ByVal pfn As Long, sThunkStr As String)
    Dim lThunkSize      As Long
    Dim lThunkPtr       As Long
    Dim bInIDE          As Boolean
 
    '--- decode thunk
    Call CryptStringToBinary(StrPtr(sThunkStr), Len(sThunkStr), CRYPT_STRING_BASE64, 0, lThunkSize, 0, 0)
    lThunkPtr = VirtualAlloc(0, lThunkSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    Call CryptStringToBinary(StrPtr(sThunkStr), Len(sThunkStr), CRYPT_STRING_BASE64, lThunkPtr, lThunkSize, 0, 0)
    '--- patch func
    Debug.Assert pvSetTrue(bInIDE)
    If bInIDE Then
        Call CopyMemory(pfn, ByVal pfn + &H16, 4)
    Else
        Call VirtualProtect(pfn, 8, PAGE_EXECUTE_READWRITE, 0)
    End If
    ' B8 00 00 00 00       mov         eax,00000000h
    ' FF E0                jmp         eax
    Call CopyMemory(ByVal pfn, 6333077358968.8504@, 8)
    Call CopyMemory(ByVal (pfn Xor &H80000000) + 1 Xor &H80000000, lThunkPtr, 4)
End Sub
 
Private Function pvSetTrue(bValue As Boolean) As Boolean
    bValue = True
    pvSetTrue = True
End Function

Final thoughts

Note that BlurBitmap assumes GDI+ library is successfully initilized w/ GdiplusStartup at some point before calling it, so to be able to get a handle to a GDI+ bitmap.

The function can be further enhanced with additional params to limit the area on the bitmap that blur effect is applied to. Just have to pass this rectangle to pvBlurChannel instead of 0, 0, uData.Width, uData.Height as it currently does.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

For comparison you can check out some measurements of IIR filters and other Gaussian blur implementations in this post by Tanner.

---

As in the post of Tanner of Mar 30th, 2015. PhotoModularFX is quoted, I want to clarify that now the performance of PhotoModularFX is much faster than what was said by that post.
Now also PhotoModularFX implements the BLUR filter using IIR https://github.com/miorsoft/Site/iss...ment-402312096
(Parameter "Mode" = Fast (IIR))

BTW
I have also implemented a fairly fast Edge Preserve Smoothing filter:
https://github.com/miorsoft/Site/iss...ment-446013494
https://github.com/miorsoft/Site/iss...ment-436457527
http://www.vbforums.com/showthread.p...=1#post5342861

You can also use the MA (moving-average) filter with very fast recursive implementation http://bbs.vbstreets.ru/viewtopic.ph...38123#p6707512
When you make the several passes the frequency responses is multiplied and impulse responses is convolved. The main advantage is the speed almost independents on the size of the filter ant the result has the linear phase:
http://www.dspguide.com/graphics/F_15_3.gif

Thanks TheTrick ! ( it will be implemented in next PhotoModularFX update )

Hello!

Thank you for the blur effect. Really cool!

I need to blur a portion of the bitmap so I have changed the call to pvBlurChannel as you suggested to include the bounding rectangle, but it doesn't work.
I get a black rectangle instead.
Can you check this for me?

Also, is there any reason to blur the alpha channel? It makes no sense, and really makes no difference...

Quote:

---

Originally Posted by DryBone

I need to blur a portion of the bitmap so I have changed the call to pvBlurChannel as you suggested to include the bounding rectangle, but it doesn't work.
I get a black rectangle instead.
Can you check this for me?

---

Welcome to the forums :wave:

I think you need to provide the rectangle, not change the parameters. Though, you didn't show what you did; so I'm just assuming.

For example, to blur rectangle: 50,50 and 100 pixels each in width,height

Code:

---

...
  Dim imgRect(0 To 3) As Long ' faux RECTI
  imgRect(0) = 50: imgRect(1) = 50  ' top/left
  imgRect(2) = 100: imgRect(3) = 100 ' width/height (not Right,Bottom like GDI rects)

  ' provide rect as 2nd parameter to:
  If GdipBitmapLockBits(hBitmap, imgRect(0), ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppARGB, uData) <> 0 Then

  ...

---

One option to tweak the code:

Code:

---

' add to declarations
Public Type RECTI
    Left As Long
    Top As Long
    Width As Long
    Height As Long
End Type

Public Function BlurBitmap( _
            ByVal hBitmap As Long, _
            ByVal sngRadius As Single, _
            Optional ByVal AffectChannels As Long = 15, _
            Optional ptrRECTI As Long = 0) As Boolean
    Dim uData          As BitmapData
    Dim dblBuffer()    As Double
 
    If GdipBitmapLockBits(hBitmap, ByVal ptrRECTI, ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppARGB, uData) <> 0 Then
        GoTo QH
    End If
...

---

And a sample call:

Code:

---

    Dim r As RECTI
    r.Left = 75: r.Top = 75: r.Width = 150: r.Height = 150
    ...
    BlurBitmap hImage, 5, , VarPtr(r)

---

Great! Thanks a lot!

Quote:

---

Originally Posted by DryBone

I need to blur a portion of the bitmap so I have changed the call to pvBlurChannel as you suggested to include the bounding rectangle, but it doesn't work.
I get a black rectangle instead.
Can you check this for me?

---

Yes, there is a non-obvious precondition for partial blur to work -- the dimensions of the dblBuffer array has to match the dimensions of the rectangle you are passing for processing to pvBlurChannel. The original description to "just" pass the rectangle to pvBlurChannel is misleading.

For instance if the rectangle is from (50, 50) to (399, 399) then the dimensions of dblBuffer has to be 350 by 350 too, i.e. use something like this

ReDim dblBuffer(0 To lWidth - 1, 0 To lHeight - 1) As Double

for this

pvBlurChannel(uData.Scan0, uData.Stride \ 4, lLeft, lTop, lWidth, lHeight, sngRadius, 0, dblBuffer)

to work on (lLeft, lTop) - (lLeft+lWidth-1, lTop+lHeight-1) rectangle.

LaVolpe's approach is viable too but I didn't think about it when designing pvBlurChannel helper function.

cheers,
</wqw>