How to Make image blur automatically moving mouse on its?

D

Dave Smith

New Member
Joined
Jul 5, 2021
Messages
32
Office Version
  1. 2016
Platform
  1. Windows
Hi,

I have created a user form but got stuck so I googled it but didn't found any proper ways to do.

As shown in attached image (for example) I want to keep image & fonts normally in normal timings but when if I brings mouse on this image then its image should get blurred and the fonts or the content should become bold or sunken (like floating). Is this type of thing is possible to do through vba?

If anybody can help through this it will be great I am not having any idea how to do this type of thing through vba.
Currently I am using 2016 excel.
 

Attachments

  • 125.JPG
    125.JPG
    102.2 KB · Views: 19

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
Oaktree said:
Easiest way is probably just to have two images (one regular and one already blurred), then use something like Rory's approach here: Can a cursor cause a picture to change in a Userform?
Click to expand...
Thank you for showing one of the way but I have talked about this in morning with my senior ones but they have declined that option

Can you pl. show any other way or pl. if you know that type of code can you pl. share ?

Regards,
 
Upvote 0
Can anybody help? I really need a help, 14th Sep is the deadline for me to submit this work. I will be grateful for your help...
 
Upvote 0
Dave Smith said:
Can anybody help? I really need a help, 14th Sep is the deadline for me to submit this work. I will be grateful for your help...
Click to expand...
See if you can adapt this vb6 code to your needs :

VB5 and VB6 Blurring algorithm-NEW & IMPROVED-VBForums

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...
www.vbforums.com
 
Upvote 0
Here is a different variant of the AlphaBlend based algorithm for blurring images.

Workbook Example






1- API code in a Standard Module:
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

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
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
                Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long

    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long

    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hUF As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hUF As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hDc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hUF As LongPtr, ByVal gaFlags As Long) 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 OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hUF As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hUF As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
   
    Private hUF As LongPtr, hObj As LongLong
#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hUF As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hUF As Long, ByVal hDc 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 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 DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hUF As Long, ByVal gaFlags As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hUF As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hUF As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
   
    Private hUF As Long, hObj As Long
#End If

Private lLeft As Long, lTop As Long
Private oUF As Object


Public Sub Blur( _
    ByVal Obj As Object, _
    Optional ByVal Enable As Boolean = True, _
    Optional ByVal DisplayText As String, _
    Optional ByVal FontName As String, _
    Optional FontSize As Long, _
    Optional ByVal FontColor As Long _
)

    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const DT_SINGLELINE = &H20
    Const GA_ROOT = 2
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const SRCCOPY = &HCC0020
    Const AC_SRC_OVER = &H0
    Const INTENSITY = 20

    #If Win64 Then
        Static hCopy As LongLong
        Dim hDc As LongLong, hMemDC As LongLong, hBufferDc As LongLong
        Dim hMemBmp As LongLong, hFont As LongLong
    #Else
        Static hCopy As Long
        Dim hDc As Long, hMemDC As Long, hBufferDc As Long
        Dim hMemBmp As Long, hFont As Long
    #End If
   
    Static bBlurred As Boolean
    Dim oPic As StdPicture
    Dim oAcc As IAccessible
    Dim tBf As BLENDFUNCTION
    Dim tBmp As BITMAP
    Dim tFont As LOGFONT
    Dim tRect As RECT
    Dim lBf As Long
    Dim SrcLeftOffset As Long, SrcTopOffset As Long
    Dim DesLeftOffset As Long, DesTopOffset As Long
    Dim WithOffset As Long, HeightOffset As Long
    Dim X As Long, Y As Long      
       
    If Not Obj.Picture Is Nothing Then
        Set oPic = Obj.Picture
        Set oUF = GetUserForm(Obj)
        Call IUnknown_GetWindow(oUF, VarPtr(hUF))
        Call IUnknown_GetWindow(Obj, VarPtr(hObj))
        If Enable Then
            If oUF.Tag = "Tagged" Then
                Exit Sub
            End If
            Set oAcc = Obj
            oAcc.accLocation lLeft, lTop, 0, 0, 0&
            Call KillTimer(hUF, 0)
            Call SetTimer(hUF, 0, 0, AddressOf TimerProc)
            If Not bBlurred Then
                hDc = GetDC(0)
                hMemDC = CreateCompatibleDC(0)
                SetBkMode hMemDC, 1
                Call SelectObject(hMemDC, oPic.handle)
                oUF.Tag = "Tagged"
                hCopy = CopyImage(oPic.handle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
                bBlurred = Enable
                Call GetObjectAPI(oPic.handle, LenB(tBmp), tBmp)
                hBufferDc = CreateCompatibleDC(0)
                With tBmp
                    hMemBmp = CreateCompatibleBitmap(hDc, .bmWidth, .bmHeight)
                End With
                Call SelectObject(hBufferDc, hMemBmp)
                With tBf
                    .BlendOp = AC_SRC_OVER
                    .BlendFlags = 0
                    .SourceConstantAlpha = 128
                    .AlphaFormat = 0
                End With
                Call CopyMemory(lBf, tBf, LenB(tBf))
                Call BitBlt(hBufferDc, 0, 0, tBmp.bmWidth, tBmp.bmHeight, hMemDC, 0, 0, SRCCOPY)
                For X = 0 To INTENSITY
                    For Y = 1 To 8
                        Select Case Y
                            Case 1
                                SrcLeftOffset = 1: WithOffset = -1
                            Case 2
                                DesLeftOffset = 1: WithOffset = -1
                            Case 3
                                SrcTopOffset = 1: HeightOffset = -1
                            Case 4
                                DesTopOffset = 1: HeightOffset = -1
                            Case 5
                                SrcLeftOffset = 1: SrcTopOffset = 1: HeightOffset = -1: WithOffset = -1
                            Case 6
                                DesLeftOffset = 1: DesTopOffset = 1: HeightOffset = -1: WithOffset = -1
                            Case 7
                                SrcLeftOffset = 1: DesTopOffset = 1: HeightOffset = -1: WithOffset = -1
                            Case 8
                                SrcTopOffset = 1: DesLeftOffset = 1: HeightOffset = -1: WithOffset = -1
                        End Select
                        Call AlphaBlend(hBufferDc, DesLeftOffset, DesTopOffset, tBmp.bmWidth + WithOffset, tBmp.bmHeight + HeightOffset, _
                        hMemDC, SrcLeftOffset, SrcTopOffset, tBmp.bmWidth + WithOffset, tBmp.bmHeight + HeightOffset, lBf)
                        Call BitBlt(hMemDC, 0, 0, tBmp.bmWidth, tBmp.bmHeight, hBufferDc, 0, 0, SRCCOPY)
                        SrcLeftOffset = 0: SrcTopOffset = 0
                        DesLeftOffset = 0: DesTopOffset = 0
                        WithOffset = 0: HeightOffset = 0
                    Next Y
                Next X
                With tFont
                    .lfHeight = FontSize
                    .lfFaceName = FontName & Chr$(0)
                End With
                hFont = CreateFontIndirect(tFont)
                Call SelectObject(hMemDC, hFont)
                Call SetTextColor(hMemDC, FontColor)
                If Len(DisplayText) Then
                    Call SetRect(tRect, 0, 0, tBmp.bmWidth, tBmp.bmHeight)
                    Call DrawText(hMemDC, DisplayText, Len(DisplayText), tRect, DT_CENTER + DT_VCENTER + DT_SINGLELINE)
                End If
                Call ReleaseDC(0, hDc)
                Call DeleteDC(hMemDC)
                Call DeleteDC(hBufferDc)
                Call DeleteObject(hMemBmp)
                bBlurred = False
                oUF.Repaint
            End If
        End If
        If Enable = False Then
            Call KillTimer(hUF, 0)
            Set Obj.Picture = PicFromBmp(hCopy)
            oUF.Tag = ""
        End If
    End If

End Sub

#If Win64 Then
    Private Function PicFromBmp(ByVal Bmp As LongLong) As StdPicture
        Dim hBmpPtr As LongLong
#Else
    Private Function PicFromBmp(ByVal Bmp As Long) As StdPicture
        Dim hBmpPtr As Long
#End If

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long
   
    hBmpPtr = CopyImage(Bmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = hBmpPtr
        .hPal = CF_BITMAP
    End With
    lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
    If lRet = S_OK Then
        Set PicFromBmp = IPic
    End If
   
End Function

Private Sub TimerProc()

    Const GA_ROOT = 2
    Dim tCurPos As POINTAPI
       Dim L  As Long, T As Long
   
    On Error Resume Next
   
    Dim vKid As Variant
    Dim oIA As IAccessible
    Dim lResult As Long
   
    Call GetCursorPos(tCurPos)
    #If Win64 Then
        Dim Ptr As LongLong, hWinUnderMouse As LongLong
        Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
        Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
        hWinUnderMouse = WindowFromPoint(Ptr)
    #Else
        Dim hWinUnderMouse  As Long
        hWinUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y)
        Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
    #End If
   
   Call oIA.accLocation(L, T, 0, 0, 0&)
    If GetAncestor(hWinUnderMouse, GA_ROOT) <> hUF Or Not (L = lLeft And T = lTop) Then
        oUF.Obj_MouseLeave
    End If

End Sub

Private Function GetUserForm(ByVal Obj As Object) As Object
    Dim oTemp As Object
       
    If TypeOf Obj Is MSForms.UserForm And TypeName(Obj) <> "Frame" Then
        Set GetUserForm = Obj
        Exit Function
    End If
    Set oTemp = Obj.Parent
    Do While TypeOf oTemp Is MSForms.Control
        Set oTemp = oTemp.Parent
    Loop
    Set GetUserForm = oTemp
End Function



2- Code Usage Example in the UserForm Module :
VBA Code: 
Option Explicit

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Blur(Me, True, "Image blurred", "Britannic Bold", 40, vbWhite)
End Sub

Public Sub Obj_MouseLeave()
    Call Blur(Me, False)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call Blur(Me, False)
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Same code can be easily adapted for Image and Frame controls.

Might be a little slow with images other than bitmaps.
 
Upvote 0
Solution
Jaafar Tribak said:
Here is a different variant of the AlphaBlend based algorithm for blurring images.

Workbook Example






1- API code in a Standard Module:
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

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
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
                Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long

    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long

    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hUF As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hUF As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hDc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hUF As LongPtr, ByVal gaFlags As Long) 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 OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hUF As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hUF As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
  
    Private hUF As LongPtr, hObj As LongLong
#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hUF As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hUF As Long, ByVal hDc 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 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 DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hUF As Long, ByVal gaFlags As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hUF As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hUF As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
  
    Private hUF As Long, hObj As Long
#End If

Private lLeft As Long, lTop As Long
Private oUF As Object


Public Sub Blur( _
    ByVal Obj As Object, _
    Optional ByVal Enable As Boolean = True, _
    Optional ByVal DisplayText As String, _
    Optional ByVal FontName As String, _
    Optional FontSize As Long, _
    Optional ByVal FontColor As Long _
)

    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const DT_SINGLELINE = &H20
    Const GA_ROOT = 2
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const SRCCOPY = &HCC0020
    Const AC_SRC_OVER = &H0
    Const INTENSITY = 20

    #If Win64 Then
        Static hCopy As LongLong
        Dim hDc As LongLong, hMemDC As LongLong, hBufferDc As LongLong
        Dim hMemBmp As LongLong, hFont As LongLong
    #Else
        Static hCopy As Long
        Dim hDc As Long, hMemDC As Long, hBufferDc As Long
        Dim hMemBmp As Long, hFont As Long
    #End If
  
    Static bBlurred As Boolean
    Dim oPic As StdPicture
    Dim oAcc As IAccessible
    Dim tBf As BLENDFUNCTION
    Dim tBmp As BITMAP
    Dim tFont As LOGFONT
    Dim tRect As RECT
    Dim lBf As Long
    Dim SrcLeftOffset As Long, SrcTopOffset As Long
    Dim DesLeftOffset As Long, DesTopOffset As Long
    Dim WithOffset As Long, HeightOffset As Long
    Dim X As Long, Y As Long     
      
    If Not Obj.Picture Is Nothing Then
        Set oPic = Obj.Picture
        Set oUF = GetUserForm(Obj)
        Call IUnknown_GetWindow(oUF, VarPtr(hUF))
        Call IUnknown_GetWindow(Obj, VarPtr(hObj))
        If Enable Then
            If oUF.Tag = "Tagged" Then
                Exit Sub
            End If
            Set oAcc = Obj
            oAcc.accLocation lLeft, lTop, 0, 0, 0&
            Call KillTimer(hUF, 0)
            Call SetTimer(hUF, 0, 0, AddressOf TimerProc)
            If Not bBlurred Then
                hDc = GetDC(0)
                hMemDC = CreateCompatibleDC(0)
                SetBkMode hMemDC, 1
                Call SelectObject(hMemDC, oPic.handle)
                oUF.Tag = "Tagged"
                hCopy = CopyImage(oPic.handle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
                bBlurred = Enable
                Call GetObjectAPI(oPic.handle, LenB(tBmp), tBmp)
                hBufferDc = CreateCompatibleDC(0)
                With tBmp
                    hMemBmp = CreateCompatibleBitmap(hDc, .bmWidth, .bmHeight)
                End With
                Call SelectObject(hBufferDc, hMemBmp)
                With tBf
                    .BlendOp = AC_SRC_OVER
                    .BlendFlags = 0
                    .SourceConstantAlpha = 128
                    .AlphaFormat = 0
                End With
                Call CopyMemory(lBf, tBf, LenB(tBf))
                Call BitBlt(hBufferDc, 0, 0, tBmp.bmWidth, tBmp.bmHeight, hMemDC, 0, 0, SRCCOPY)
                For X = 0 To INTENSITY
                    For Y = 1 To 8
                        Select Case Y
                            Case 1
                                SrcLeftOffset = 1: WithOffset = -1
                            Case 2
                                DesLeftOffset = 1: WithOffset = -1
                            Case 3
                                SrcTopOffset = 1: HeightOffset = -1
                            Case 4
                                DesTopOffset = 1: HeightOffset = -1
                            Case 5
                                SrcLeftOffset = 1: SrcTopOffset = 1: HeightOffset = -1: WithOffset = -1
                            Case 6
                                DesLeftOffset = 1: DesTopOffset = 1: HeightOffset = -1: WithOffset = -1
                            Case 7
                                SrcLeftOffset = 1: DesTopOffset = 1: HeightOffset = -1: WithOffset = -1
                            Case 8
                                SrcTopOffset = 1: DesLeftOffset = 1: HeightOffset = -1: WithOffset = -1
                        End Select
                        Call AlphaBlend(hBufferDc, DesLeftOffset, DesTopOffset, tBmp.bmWidth + WithOffset, tBmp.bmHeight + HeightOffset, _
                        hMemDC, SrcLeftOffset, SrcTopOffset, tBmp.bmWidth + WithOffset, tBmp.bmHeight + HeightOffset, lBf)
                        Call BitBlt(hMemDC, 0, 0, tBmp.bmWidth, tBmp.bmHeight, hBufferDc, 0, 0, SRCCOPY)
                        SrcLeftOffset = 0: SrcTopOffset = 0
                        DesLeftOffset = 0: DesTopOffset = 0
                        WithOffset = 0: HeightOffset = 0
                    Next Y
                Next X
                With tFont
                    .lfHeight = FontSize
                    .lfFaceName = FontName & Chr$(0)
                End With
                hFont = CreateFontIndirect(tFont)
                Call SelectObject(hMemDC, hFont)
                Call SetTextColor(hMemDC, FontColor)
                If Len(DisplayText) Then
                    Call SetRect(tRect, 0, 0, tBmp.bmWidth, tBmp.bmHeight)
                    Call DrawText(hMemDC, DisplayText, Len(DisplayText), tRect, DT_CENTER + DT_VCENTER + DT_SINGLELINE)
                End If
                Call ReleaseDC(0, hDc)
                Call DeleteDC(hMemDC)
                Call DeleteDC(hBufferDc)
                Call DeleteObject(hMemBmp)
                bBlurred = False
                oUF.Repaint
            End If
        End If
        If Enable = False Then
            Call KillTimer(hUF, 0)
            Set Obj.Picture = PicFromBmp(hCopy)
            oUF.Tag = ""
        End If
    End If

End Sub

#If Win64 Then
    Private Function PicFromBmp(ByVal Bmp As LongLong) As StdPicture
        Dim hBmpPtr As LongLong
#Else
    Private Function PicFromBmp(ByVal Bmp As Long) As StdPicture
        Dim hBmpPtr As Long
#End If

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long
  
    hBmpPtr = CopyImage(Bmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = hBmpPtr
        .hPal = CF_BITMAP
    End With
    lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
    If lRet = S_OK Then
        Set PicFromBmp = IPic
    End If
  
End Function

Private Sub TimerProc()

    Const GA_ROOT = 2
    Dim tCurPos As POINTAPI
       Dim L  As Long, T As Long
  
    On Error Resume Next
  
    Dim vKid As Variant
    Dim oIA As IAccessible
    Dim lResult As Long
  
    Call GetCursorPos(tCurPos)
    #If Win64 Then
        Dim Ptr As LongLong, hWinUnderMouse As LongLong
        Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
        Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
        hWinUnderMouse = WindowFromPoint(Ptr)
    #Else
        Dim hWinUnderMouse  As Long
        hWinUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y)
        Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
    #End If
  
   Call oIA.accLocation(L, T, 0, 0, 0&)
    If GetAncestor(hWinUnderMouse, GA_ROOT) <> hUF Or Not (L = lLeft And T = lTop) Then
        oUF.Obj_MouseLeave
    End If

End Sub

Private Function GetUserForm(ByVal Obj As Object) As Object
    Dim oTemp As Object
      
    If TypeOf Obj Is MSForms.UserForm And TypeName(Obj) <> "Frame" Then
        Set GetUserForm = Obj
        Exit Function
    End If
    Set oTemp = Obj.Parent
    Do While TypeOf oTemp Is MSForms.Control
        Set oTemp = oTemp.Parent
    Loop
    Set GetUserForm = oTemp
End Function



2- Code Usage Example in the UserForm Module :
VBA Code: 
Option Explicit

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Blur(Me, True, "Image blurred", "Britannic Bold", 40, vbWhite)
End Sub

Public Sub Obj_MouseLeave()
    Call Blur(Me, False)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call Blur(Me, False)
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Same code can be easily adapted for Image and Frame controls.

Might be a little slow with images other than bitmaps.
Click to expand...
Thank a lot for helping me out for this :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
694
Dan_W
D
U
  • Question
Excel Ribbon button icon change effect
Replies
3
Views
1K
jkpieterse
jkpieterse
R
  • Question
Shape objects distorting on Mac only (not Windows)
Replies
0
Views
265
rline101
R
A
  • Question
Excel VBA Code to Open Images on other computers
Replies
1
Views
490
Micron
M
M
  • Solved
VBA Label Font goes Bold and Underline when moving mouse over
Replies
4
Views
2K
Domenic
D

Forum statistics

Threads
1,221,498
Messages
6,160,161
Members
451,627
Latest member
WORBY10

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top