Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,779
- Office Version
- 2016
- Platform
- 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 :
2-(Implementation Class) Add a Userform to you VBAProject and give it the name of : CWorksheetGIF
UserForm Module code :
3- Add a Standard Module and place the following helper code in it :
4- Finally, in order to test Code, add a new Standard Module and place the following code in it:
Save and close the workbook so the code takes effect after it is next re-opened.
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.