VB5 and VB6 Blurring algorithm-NEW & IMPROVED

[technorobbo]

Post Edited to refine technique

Last time I helped someone out with a blurring algorithm I was dissatisfied with the speed, so I beveloped a superfast algorithm. Here it is.

You'll need 1 form and a jpg of Jessica simpson.
Put this code in the form:

Option Explicit
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private Type BITMAPINFOHEADER '40 bytes
        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 RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type
Const AC_SRC_OVER = &H0
Private Type BLENDFUNCTION
  BlendOp As Byte
  BlendFlags As Byte
  SourceConstantAlpha As Byte
  AlphaFormat As Byte
End Type
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetTickCount& Lib "kernel32" ()

Dim STD As StdPicture, STDHdc As Long, STDSpec As BITMAP, PicPos As RECT
Dim BufBit As Long, BufHdc As Long
Dim bi24BitInfo As BITMAPINFO

Dim bf As BLENDFUNCTION, filestr As String



Private Sub Form_KeyPress(KeyAscii As Integer)
Dim x As Long, ky As Integer

If Me.MousePointer = 11 Then Exit Sub

ky = KeyAscii - 48

If ky > 9 Or ky < 0 Then Exit Sub

MousePointer = 11
Set STD = LoadPicture(filestr)
STDHdc = CreateCompatibleDC(0)
SelectObject STDHdc, STD.handle

x = GetTickCount
blur ky
x = GetTickCount - x

DeleteDC STDHdc

MousePointer = 0

MsgBox x & " ms at level " & ky

End Sub


Private Sub Form_Load()
filestr = App.Path & "\js.jpg"

Me.Caption = "Press a key from 1 to 9 or 0 to reset"
Me.WindowState = 2
Me.Show
Me.ScaleMode = vbPixels

Me.AutoRedraw = False
Me.ScaleMode = vbPixels
Me.BackColor = 0&
Me.Cls
DoEvents

Set STD = LoadPicture(filestr)
GetObject STD.handle, Len(STDSpec), STDSpec

With bi24BitInfo.bmiHeader
    .biBitCount = 24
    .biCompression = BI_RGB
    .biPlanes = 1
    .biSize = Len(bi24BitInfo.bmiHeader)
    .biWidth = STDSpec.bmWidth
    .biHeight = STDSpec.bmHeight
End With
BufHdc = CreateCompatibleDC(0)
BufBit = CreateDIBSection(BufHdc, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
SelectObject BufHdc, BufBit

With PicPos
    .Left = Me.ScaleWidth / 2 - STDSpec.bmWidth / 2
    .Top = Me.ScaleHeight / 2 - STDSpec.bmHeight / 2
    .Right = STDSpec.bmWidth
    .Bottom = STDSpec.bmHeight
End With

STDHdc = CreateCompatibleDC(0)
SelectObject STDHdc, STD.handle
BitBlt Me.hdc, PicPos.Left, PicPos.Top, PicPos.Right, PicPos.Bottom, _
    STDHdc, 0, 0, vbSrcCopy
DeleteDC STDHdc

End Sub

Private Sub Form_Unload(Cancel As Integer)
DeleteDC STDHdc
DeleteDC BufHdc
DeleteObject BufBit
End Sub


Private Sub blur(intensity As Integer)
Dim x As Long, y As Long, SPREAD As Single, LBF As Long

SPREAD = 128
With bf
    .BlendOp = AC_SRC_OVER
    .BlendFlags = 0
    .SourceConstantAlpha = SPREAD
    .AlphaFormat = 0
End With
    RtlMoveMemory LBF, bf, 4

BitBlt BufHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
    STDHdc, 0, 0, vbSrcCopy
If intensity > 0 Then
    For x = 0 To intensity - 1
            AlphaBlend BufHdc, 0, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight, _
                STDHdc, 1, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 1, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight, _
                STDHdc, 0, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight - 1, _
                STDHdc, 0, 1, STDSpec.bmWidth, STDSpec.bmHeight - 1, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 0, 1, STDSpec.bmWidth, STDSpec.bmHeight - 1, _
                STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight - 1, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 0, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, _
                STDHdc, 1, 1, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 1, 1, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, _
                STDHdc, 0, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 0, 1, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, _
                STDHdc, 1, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
            AlphaBlend BufHdc, 1, 0, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, _
                STDHdc, 0, 1, STDSpec.bmWidth - 1, STDSpec.bmHeight - 1, LBF
            BitBlt STDHdc, 0, 0, STDSpec.bmWidth, STDSpec.bmHeight, _
                BufHdc, 0, 0, vbSrcCopy
    Next
End If
BitBlt Me.hdc, PicPos.Left, PicPos.Top, PicPos.Right, PicPos.Bottom, _
    BufHdc, 0, 0, vbSrcCopy

End Sub

Here's a little secret you don't actually need to use a picture of jessica simpson. You can use any picture.

 

[technorobbo]

Post edited and tightened to 9 levels this algorithm rocks

 

[Skittles]

I'm tinkering with your code to blur images

The image I was to blur is in a picturebox. I made a few changes to accommodate this, for example...
From

BitBlt me.hdc, PicPos.Left, PicPos.Top, PicPos.Right, PicPos.Bottom, _
    STDHdc, 0, 0, vbSrcCopy

To

BitBlt frmPicture.picDisp.hdc, PicPos.Left, PicPos.Top, PicPos.Right, PicPos.Bottom, _
    STDHdc, 0, 0, vbSrcCopy

I need a little more guidance. I'm not receiving run-time errors, but it's not blurring the image.


Thank you for your time, efforts and code.

Joe

 

[passel]

Not being sure of your competence but assuming you have the picture showing up in the picturebox so the hdc and PicPos values are correct and Picturebox is set to pixel scalemode, then probably if you didn't move the key processing to the picturebox's event handler that would be a problem.
Set the Form's KeyPreview property to True and see if that helps.

 

[Skittles]

Thanks for your time... I got it working.
I need to start waiting a day instead of a couple hours, before asking for help. That way I don't waste peoples time.

My problem was a combination of transferring the "frmPicture.picdisp.image" property to the "frmPicture.picdisp.picture" property after applying the blur and not reloading the picture from the file... It's a long story. But, thanks again for responding.

 

[Mikle]

I propose a much more fast and high quality blur. The speed does not depend on the radius. To estimate the speed, it is desirable to compile the project.