-
Dec 18th, 2018, 04:39 PM
#1
[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>
Last edited by wqweto; Dec 19th, 2018 at 06:29 AM.
-
Jan 4th, 2019, 03:02 PM
#2
Re: [VB6] Blur effect on GDI+ bitmaps
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
-
Jan 4th, 2019, 03:45 PM
#3
Re: [VB6] Blur effect on GDI+ bitmaps
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:
-
Jan 4th, 2019, 08:00 PM
#4
Re: [VB6] Blur effect on GDI+ bitmaps
Thanks TheTrick ! ( it will be implemented in next PhotoModularFX update )
-
Jul 16th, 2020, 12:46 PM
#5
New Member
Re: [VB6] Blur effect on GDI+ bitmaps
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...
-
Jul 16th, 2020, 03:09 PM
#6
Re: [VB6] Blur effect on GDI+ bitmaps
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
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)
Last edited by LaVolpe; Jul 16th, 2020 at 03:34 PM.
-
Jul 17th, 2020, 12:54 AM
#7
New Member
Re: [VB6] Blur effect on GDI+ bitmaps
-
Jul 17th, 2020, 04:23 AM
#8
Re: [VB6] Blur effect on GDI+ bitmaps
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>
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|