VB5 and VB6 Blurring algorithm-NEW & IMPROVED-VBForums
Results 1 to 2 of 2

Thread: VB5 and VB6 Blurring algorithm-NEW & IMPROVED

Hybrid View

  1. #1

    Thread Starter
    Fanatic Member technorobbo's Avatar
    Join Date
    Dec 2008
    Location
    Chicago
    Posts
    864

    VB5 and VB6 Blurring algorithm-NEW & IMPROVED

    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:
    Code:
    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.
    Last edited by technorobbo; Apr 8th, 2009 at 07:13 AM. Reason: Refined technique
    Have Fun,

    TR
    _____________________________
    Check out my Alpha DogFighter2D Game Demo and Source code. Direct Download:http://home.comcast.net/~technorobbo/Alpha.zip or Read about it in the forum:http://www.vbforums.com/showthread.php?t=551700. Now in 3D!!! http://home.comcast.net/~technorobbo/AlPha3D.zip or read about it in the forum: http://www.vbforums.com/showthread.php?goto=newpost&t=552560 and IChessChat3D internet chess game

  2. #2

    Thread Starter
    Fanatic Member technorobbo's Avatar
    Join Date
    Dec 2008
    Location
    Chicago
    Posts
    864

    Re: VB5 and VB6 Blurring algorithm-NEW & IMPROVED

    Post edited and tightened to 9 levels this algorithm rocks
    Have Fun,

    TR
    _____________________________
    Check out my Alpha DogFighter2D Game Demo and Source code. Direct Download:http://home.comcast.net/~technorobbo/Alpha.zip or Read about it in the forum:http://www.vbforums.com/showthread.php?t=551700. Now in 3D!!! http://home.comcast.net/~technorobbo/AlPha3D.zip or read about it in the forum: http://www.vbforums.com/showthread.php?goto=newpost&t=552560 and IChessChat3D internet chess game

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.