Can't Insert ActiveX Control Issue ( An API- Based Workaround - GIF Control Demo )

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,806
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

Recent Office security updates has broken ActiveX controls on worksheets .. The usual and rather long-winded fix (Which may not always work) is to locate all exd files and delete them or install the following updates.

Here, I took a different approach. I added the ActiveX controls (In this case, I added WebBroser/GIF controls) to a userform at runtime and then via several API calls, I transferred the controls onto the worksheet at designated worksheet locations priorly chosen by the user.

I hope the code is robust enough and that you will find it useful.

Workbook Demo

Project Components :

1- (Interface Class) Add a Class Module to your VBAProject and give it the name of IWorksheetGIF

Interface Class code :
Code: 
Option Explicit

Public Sub Add( _
    ByVal GifName As String, _
    ByVal TargetRange As Range, _
    ByVal GIF_FilePathName As String, _
    Optional ByVal TransparentBackground As Boolean = False, _
    Optional ByVal OnActionMacro As String = vbNullString)

End Sub

Public Sub Remove()

End Sub

2-(Implementation Class) Add a Userform to you VBAProject and give it the name of : CWorksheetGIF

UserForm Module code :
Code: 
Option Explicit

Implements IWorksheetGIF

Private WithEvents oThisWorkbook As Workbook

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 OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

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

Private Type KeyboardBytes
     kbByte(0 To 255) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As LongPtr)
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

    Private hwndXL7 As LongPtr, hUserForm As LongPtr, hBrowser As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

    Private hwndXL7 As Long, hUserForm As Long, hBrowser As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const IES = "Internet Explorer_Server"
Private Const XL7 = "EXCEL7"
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const LWA_COLORKEY = &H1
Private Const GWL_HWNDPARENT = (-8)
Private Const GW_CHILD = 5
Private Const GA_ROOTOWNER = 3
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72
Private Const SM_CYHSCROLL = 3
Private Const WM_CLOSE = &H10

Private bPopupShowing As Boolean
Private bTransparentBackgroud As Boolean
Private bWbrDocEventsSink As Boolean

Private oTargetRange As Range, sGIF_FilePathName As String, oTargetSheet As Worksheet, sOnActionMacro As String
Private sClassName1 As String, sClassName2 As String, sClassName3 As String, sClassName4 As String
Private tTargetRangeRect As RECT, tPrevRngRect As RECT, tPrevXL7Rect As RECT, tPrevAppRect As RECT
Private tCurXL7Rect As RECT, tCurAppRect As RECT

Private tIID As GUID
Private kbArray As KeyboardBytes
Private oWebBrowser As Object
Private oWebBrowserObject As Object
Private lCookie As Long
Private lDelay As Long

[COLOR=#008000]'Interface Methods.[/COLOR]
[COLOR=#008000]'=================[/COLOR]
Private Sub IWorksheetGIF_Add( _
    ByVal GifName As String, _
    ByVal TargetRange As Range, _
    ByVal GIF_FilePathName As String, _
    Optional ByVal TransparentBackground As Boolean = False, _
    Optional ByVal OnActionMacro As String = vbNullString _
    )

    sOnActionMacro = OnActionMacro
    Set oTargetRange = TargetRange
    Set oTargetSheet = TargetRange.Parent
    Set oThisWorkbook = ThisWorkbook
    sGIF_FilePathName = GIF_FilePathName
    bTransparentBackgroud = TransparentBackground
    
    Call CreateWebBrowserControl(GifName)
    WindowFromAccessibleObject Me, hUserForm
    ShowWindow hUserForm, 0
    hwndXL7 = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwndXL7 = FindWindowEx(hwndXL7, 0, XL7, vbNullString)
    oGifsCollection.Add Me, oWebBrowser.Name
    hBrowser = GetNextWindow(hUserForm, GW_CHILD)
    hBrowser = GetNextWindow(hBrowser, GW_CHILD)
    SetWindowLong hBrowser, GWL_HWNDPARENT, Application.hwnd
    SetWindowPos hBrowser, 0, -100, -100, 1, 1, SWP_HIDEWINDOW
End Sub

Private Sub IWorksheetGIF_Remove()
    Call DeleteMe
End Sub

[COLOR=#008000]'Timer routine.[/COLOR]
[COLOR=#008000]'=============[/COLOR]
Private Sub TimerProcedure()

    Static tRangeLoc1 As POINTAPI, tRangeLoc2 As POINTAPI, tRangeLoc3 As POINTAPI, tRangeLoc4 As POINTAPI
    Static tP1 As POINTAPI, tP2 As POINTAPI
   
    On Error Resume Next

    KillTimer hUserForm, 0

    If oTargetSheet Is ActiveSheet Then
    
        Call SinkWebBrowserEvents
        Call SetWebControlStyles(oWebBrowserObject)
        Call MakeWebBrowserBackgroundTransparent
        Call RunRightClickPopUpMenuMacro
        Call GetCurrentTargetRangeScreenLocation

        With tTargetRangeRect
            tRangeLoc1.x = .Left: tRangeLoc1.y = .Top 'IIf(ActiveWindow.DisplayHeadings = True, .Top - GetSystemMetrics(SM_CYHSCROLL), .Top)
            tRangeLoc2.x = .Left: tRangeLoc2.y = .Bottom 'IIf(ActiveWindow.DisplayWorkbookTabs = True, .Bottom - GetSystemMetrics(SM_CYHSCROLL), .Bottom)
            tRangeLoc3.x = .Right: tRangeLoc3.y = .Top
            tRangeLoc4.x = .Right: tRangeLoc4.y = .Bottom
        End With
        
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
            Dim hwndFromPoint1 As LongPtr, hwndFromPoint2 As LongPtr
            Dim hwndFromPoint3 As LongPtr, hwndFromPoint4 As LongPtr
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            Dim hwndFromPoint1 As Long, hwndFromPoint2 As Long
            Dim hwndFromPoint3 As Long, hwndFromPoint4 As Long
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        
        hwndFromPoint1 = GetHwndFromPoint(tRangeLoc1)
        hwndFromPoint2 = GetHwndFromPoint(tRangeLoc2)
        hwndFromPoint3 = GetHwndFromPoint(tRangeLoc3)
        hwndFromPoint4 = GetHwndFromPoint(tRangeLoc4)
        
        sClassName1 = GetWindowClassName(hwndFromPoint1)
        sClassName2 = GetWindowClassName(hwndFromPoint2)
        sClassName3 = GetWindowClassName(hwndFromPoint3)
        sClassName4 = GetWindowClassName(hwndFromPoint4)
    
        If IsWebBrowserWithinVisibleRange Then
            If TragetRangeScreenPosChanged Then
                With tTargetRangeRect
                    tP1.x = .Left: tP1.y = .Top: tP2.x = .Right: tP2.y = .Bottom
                End With
                ScreenToClient Application.hwnd, tP1
                ScreenToClient Application.hwnd, tP2
                SetWindowPos hBrowser, 0, tP1.x, tP1.y, tP2.x - tP1.x, tP2.y - tP1.y, SWP_SHOWWINDOW
                lDelay = lDelay + 1 
            End If
        Else
            If GetAncestor(GetForegroundWindow, GA_ROOTOWNER) <> Application.hwnd Or _
            GetForegroundWindow = Application.hwnd And bPopupShowing = False Then
                ShowWebBrowser False
            Else
                ShowWebBrowser
            End If
            If GetForegroundWindow <> Application.hwnd Then
                 ShowWebBrowser
            End If
            lDelay = 0
        End If
    Else
        ShowWebBrowser False
    End If

    Call StorePreviousTargetRangeScreenLocation
End Sub

[COLOR=#008000]'Supporting routines.[/COLOR]
[COLOR=#008000]'====================[/COLOR]
Private Sub UserForm_Layout()
    oWebBrowserObject.Navigate (sGIF_FilePathName)
    SetTimer hUserForm, 0, 2000, AddressOf DelegateTimerRoutine
End Sub

Private Sub CreateWebBrowserControl(ByVal GifControlName As String)
    Set oWebBrowser = Me.Controls.Add("Shell.Explorer", GifControlName, True)
    Set oWebBrowserObject = oWebBrowser.Object
End Sub

Private Sub DeleteMe()
    On Error Resume Next
    KillTimer hUserForm, 0
    Call ConnectToConnectionPoint(Nothing, tIID, 0, oWebBrowserObject.Document, lCookie)
    oGifsCollection.Remove oWebBrowser.Name
    Set oWebBrowserObject = Nothing
    Set oWebBrowser = Nothing
    If oGifsCollection.Count = 0 Then Set oGifsCollection = Nothing
    SendMessage hUserForm, WM_CLOSE, 0, 0
'    Unload Me
End Sub

Private Sub Sink_oWebBrowser_Document_Events()
    Const sIID = "{3050F260-98B5-11CF-BB82-00AA00BDCE0B}"
    Call IIDFromString(StrPtr(sIID), tIID)
    Call ConnectToConnectionPoint(Me, tIID, 1, oWebBrowserObject.Document, lCookie)
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function GetHwndFromPoint(ByRef Pnt As POINTAPI) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function GetHwndFromPoint(ByRef Pnt As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
                Dim lngPtr As LongPtr
                CopyMemory lngPtr, Pnt, LenB(Pnt)
                GetHwndFromPoint = WindowFromPoint(lngPtr)
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                GetHwndFromPoint = WindowFromPoint(Pnt.x, Pnt.y)
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            GetHwndFromPoint = WindowFromPoint(Pnt.x, Pnt.y)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Function

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function GetWindowClassName(ByVal hwnd As LongPtr) As String
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function GetWindowClassName(ByVal hwnd As Long) As String
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Dim sBuffer As String, lRet As Long
    sBuffer = Space(256)
    lRet = GetClassName(hwnd, sBuffer, 256)
    GetWindowClassName = Left(sBuffer, lRet)
End Function

Private Sub SetWebControlStyles(ByVal WBC As Object)
    With WBC
        .Document.write "[IMG]https://www.mrexcel.com/forum/ & sGIF_FilePathName & [/IMG]"
        .Document.body.Style.margin = 1
        .Document.body.Style.Border = 0
        .Document.body.Scroll = "no"
    End With
End Sub

Private Function IsWebBrowserWithinVisibleRange() As Boolean
    IsWebBrowserWithinVisibleRange = _
    ((sClassName1 = IES) Or (sClassName1 = XL7)) And ((sClassName2 = IES) Or (sClassName2 = XL7)) And _
    ((sClassName3 = IES) Or (sClassName3 = XL7)) And ((sClassName4 = IES) Or (sClassName4 = XL7))
End Function

Private Function TragetRangeScreenPosChanged() As Boolean
    tTargetRangeRect = GetRangeRect(oTargetRange)
    GetWindowRect hwndXL7, tCurXL7Rect
    GetWindowRect Application.hwnd, tCurAppRect
    With tTargetRangeRect
        If (lDelay <= 10 Or tPrevRngRect.Left <> .Left Or tPrevRngRect.Top <> .Top Or _
        tPrevRngRect.Right <> .Right Or tPrevRngRect.Bottom <> .Bottom) Or _
        tPrevAppRect.Left <> tCurAppRect.Left Or tPrevAppRect.Top <> tCurAppRect.Top Or _
        tPrevAppRect.Right <> tCurAppRect.Right Or tPrevAppRect.Bottom <> tCurAppRect.Bottom Or _
        tPrevXL7Rect.Left <> tCurXL7Rect.Left Or tPrevXL7Rect.Top <> tCurXL7Rect.Top Or _
        tPrevXL7Rect.Right <> tCurXL7Rect.Right Or tPrevXL7Rect.Bottom <> tCurXL7Rect.Bottom Then
            TragetRangeScreenPosChanged = True
        End If
    End With
End Function

Private Sub SinkWebBrowserEvents()
    If bWbrDocEventsSink = False Then Call Sink_oWebBrowser_Document_Events: bWbrDocEventsSink = True
End Sub

Private Sub RunRightClickPopUpMenuMacro()
    If IsCursorOverPopUp And IsMouseLeftButtonPressed And bPopupShowing Then
        bPopupShowing = False
        Call RightClickPopUpMacro
    End If
End Sub

Private Sub MakeWebBrowserBackgroundTransparent()
    [COLOR=#008000]'WS_EX_LAYERED style for child windows only available on Windows8 or later !![/COLOR]
    If bTransparentBackgroud And GetWinVersion >= 6.2 Then
        If oWebBrowserObject.Document.body.bgColor <> "#ff00ff" Then
            MakeTransparent
        End If
    End If
End Sub

Private Sub ShowWebBrowser(Optional ByVal show As Boolean = True)
     ShowWindow hBrowser, show
End Sub

Private Sub GetCurrentTargetRangeScreenLocation()
    tTargetRangeRect = GetRangeRect(oTargetRange)
    GetWindowRect hwndXL7, tCurXL7Rect
    GetWindowRect Application.hwnd, tCurAppRect
End Sub

Private Sub StorePreviousTargetRangeScreenLocation()
    With tTargetRangeRect
        tPrevRngRect.Left = .Left: tPrevRngRect.Top = .Top: tPrevRngRect.Right = .Right: tPrevRngRect.Bottom = .Bottom
    End With
    With tCurAppRect
        tPrevAppRect.Left = .Left: tPrevAppRect.Top = .Top: tPrevAppRect.Right = .Right: tPrevAppRect.Bottom = .Bottom
    End With
    With tCurXL7Rect
        tPrevXL7Rect.Left = .Left: tPrevXL7Rect.Top = .Top: tPrevXL7Rect.Right = .Right: tPrevXL7Rect.Bottom = .Bottom
    End With
End Sub

Private Function IsMouseLeftButtonPressed() As Boolean
    IsMouseLeftButtonPressed = GetAsyncKeyState(VBA.vbKeyLButton)
End Function

Private Function IsCursorOverPopUp() As Boolean
    Dim tCurPos As POINTAPI
    
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim hwndFromPoint As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Dim hwndFromPoint As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        GetCursorPos tCurPos
        hwndFromPoint = GetHwndFromPoint(tCurPos)
        If GetWindowClassName(hwndFromPoint) = "MsoCommandBarPopup" Then IsCursorOverPopUp = True
End Function

Private Sub oThisWorkbook_SheetActivate(ByVal Sh As Object)
    If Sh Is oTargetSheet Then
     ShowWebBrowser
    End If
End Sub

Private Sub MakeTransparent()
    With oWebBrowserObject
        .Document.body.bgColor = "#ff00ff"
        Call SetWindowLong(hBrowser, GWL_EXSTYLE, GetWindowLong(hBrowser, GWL_EXSTYLE) Or WS_EX_LAYERED)
        SetLayeredWindowAttributes hBrowser, RGB(255, 0, 255), 255, LWA_COLORKEY
    End With
End Sub

Private Function GetRangeRect(ByVal TargetRange As Range) As RECT
    Dim OWnd  As Window
    
    Set OWnd = TargetRange.Parent.Parent.Windows(1)
    With TargetRange
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
End Function

Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
   If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Sub RightClickPopUpMacro()
    Call DeleteMe
End Sub

Private Sub ShowRightClickPopUp()
    Dim oCmb As CommandBar
    
    bPopupShowing = True
    On Error Resume Next
    CommandBars("PopUp").Delete
     On Error GoTo 0
    Set oCmb = Application.CommandBars.Add _
    (Position:=msoBarPopup, Temporary:=True)
    With oCmb
        oCmb.Name = "PopUp"
        With .Controls.Add(msoControlButton)
            .Caption = "Delete me"
            .FaceId = 847
             oCmb.ShowPopup
        End With
    End With

End Sub

Private Function GetWinVersion() As Single
    Dim tOSInfo As OSVERSIONINFO
    
    tOSInfo.dwOSVersionInfoSize = Len(tOSInfo)
    Call GetVersionEx(tOSInfo)
    GetWinVersion = Val(Str(tOSInfo.dwMajorVersion) + "." + LTrim(Str(tOSInfo.dwMinorVersion)))
End Function

Private Sub oThisWorkbook_BeforeClose(Cancel As Boolean)
    Call DeleteMe
End Sub

[COLOR=#008000]'Public routines[/COLOR]
[COLOR=#008000]'===============[/COLOR]
Public Function OnContextMenu() As Boolean
    Attribute OnContextMenu.VB_UserMemId = 1023
    [COLOR=#008000]' Attribute OnContextMenu.VB_UserMemId = 1023[/COLOR]
    OnContextMenu = False
    ShowRightClickPopUp
    bPopupShowing = False
    SetFocus Application.hwnd
End Function

Public Function OnLeftClick() As Boolean
    Attribute OnLeftClick.VB_UserMemId = -600
    [COLOR=#008000]' Attribute OnLeftClick.VB_UserMemId = -600[/COLOR]
    GetKeyboardState kbArray
    kbArray.kbByte(vbKeyLButton) = 1
    SetKeyboardState kbArray
    If GetKeyState(VBA.vbKeyLButton) Then
        If Len(sOnActionMacro) <> 0 Then
            Application.Run sOnActionMacro, oWebBrowser.Name
        End If
    End If
End Function

Public Sub TimerProc()
    KillTimer hUserForm, 0
    KillTimer Application.hwnd, 0
    Call TimerProcedure
    Call SetTimer(hUserForm, 0, 0, AddressOf DelegateTimerRoutine)
End Sub

3- Add a Standard Module and place the following helper code in it :
Code: 
Option Explicit

[COLOR=#008000]'======================================[/COLOR]
[COLOR=#008000]'Do Not modify the code in this module ![/COLOR]
[COLOR=#008000]'======================================[/COLOR]

Public oGifsCollection As New Collection

Public Sub DelegateTimerRoutine()
    Dim i As Long
    
    On Error Resume Next
    For i = 1 To oGifsCollection.Count
         oGifsCollection.Item(i).TimerProc
    Next
End Sub

4- Finally, in order to test Code, add a new Standard Module and place the following code in it:
Code: 
Option Explicit

Private oGifsCollection As Collection
Private GIF1 As IWorksheetGIF, GIF2 As IWorksheetGIF, GIF3 As IWorksheetGIF

Public Sub ShowTheGIFs()

    Set oGifsCollection = New Collection
    Set GIF1 = New CWorksheetGIF
    Set GIF2 = New CWorksheetGIF
    Set GIF3 = New CWorksheetGIF
    
    Call GIF1.Add( _
        GifName:="spos", _
        TargetRange:=Sheet1.Range("B3"), _
        GIF_FilePathName:="http://www.cslab.ece.ntua.gr/~phib/images/doom/anim/spos00.gif", _
        TransparentBackground:=True, OnActionMacro:="ClickMacro" _
         )
         
    oGifsCollection.Add GIF1
         
    Call GIF2.Add( _
        GifName:="FunnyCryingBaby", _
        TargetRange:=Sheet1.Range("J3"), _
        GIF_FilePathName:="https://gifyu.com/images/CuteFunnyBabyCrying.gif", _
        OnActionMacro:="ClickMacro" _
         )
    oGifsCollection.Add GIF2
    
    Call GIF3.Add( _
        GifName:="Ball", _
        TargetRange:=Sheet1.Range("F5"), _
        GIF_FilePathName:="https://s1.gifyu.com/images/ball.gif", _
        TransparentBackground:=True, OnActionMacro:="ClickMacro" _
         )
    
    oGifsCollection.Add GIF3

End Sub

Public Sub RemoveTheGIFs()
    Dim i As Integer
    
    On Error Resume Next
    For i = 1 To oGifsCollection.Count
        oGifsCollection.Item(i).Remove
    Next i
    Set oGifsCollection = Nothing
End Sub

[COLOR=#008000]'GIFs OnAction Macro.[/COLOR]
[COLOR=#008000]'===================[/COLOR]
Public Sub ClickMacro(ByVal Gif_Name As String)
    MsgBox "You clicked GIF control: '" & Gif_Name & "'"
End Sub

Save and close the workbook so the code takes effect after it is next re-opened.
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
1
Views
395
Bib195
B
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
721
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
861
Jaafar Tribak
Jaafar Tribak
A
  • Question Question
Using Hittest with more than one Listview Control
Replies
0
Views
36
AlexanderBB
A
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

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