Option Explicit
#If Win64 Then
Private Const NULL_PTR = 0^
#Else
Private Const NULL_PTR = 0&
#End If
#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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 InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Any, ByVal bErase As Long) As Long
' GDI+ x64bit API functions
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipLoadImageFromFile Lib "GDIPlus" (ByVal sFileName As LongPtr, hImage As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateFromHDC Lib "GDIPlus" (ByVal hDC As LongPtr, hGraphics As LongPtr) As Long
Private Declare PtrSafe Function GdipDrawImageRectI Lib "GdiPlus.dll" (ByVal graphics As LongPtr, ByVal img As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Any, ByVal bErase As Long) As Long
' GDI+ 32bit API functions
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare Function GdipLoadImageFromFile Lib "GDIPlus" (ByVal sFileName As LongPtr, hImage As LongPtr) As Long
Private Declare Function GdipCreateFromHDC Lib "GDIPlus" (ByVal hDC As LongPtr, hGraphics As LongPtr) As Long
Private Declare Function GdipDrawImageRectI Lib "GdiPlus.dll" (ByVal graphics As LongPtr, ByVal img As LongPtr, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As LongPtr) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As Long
#End If
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 GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As LongPtr
SuppressExternalCodecs As Long
End Type
Public Function RollOverImage( _
ByVal imgFilePathName As String, _
ByVal imgDisplayAnchorCell As Range, _
Optional ByVal imgWidth As Long, _
Optional ByVal imgHeight As Long _
)
Static bLooping As Boolean
Dim oTargetCell As Range, oCurHoveredObject As Object
Dim uCurPos As POINTAPI
Set oTargetCell = Application.Caller
GetCursorPos uCurPos
If InStr(oTargetCell.Formula, "HYPERLINK(RollOverImage") Then
If bLooping = False Then
Do
bLooping = True
DoEvents
GetCursorPos uCurPos
Set oCurHoveredObject = ActiveWindow.RangeFromPoint(uCurPos.X, uCurPos.Y)
If TypeName(oCurHoveredObject) = "Nothing" Then Exit Do
If oTargetCell.Address <> oCurHoveredObject.Address Then Exit Do
Call DrawImageToSreenDC(imgFilePathName, imgDisplayAnchorCell, imgWidth, imgHeight)
Loop
InvalidateRect NULL_PTR, ByVal 0&, 0&
End If
bLooping = False
End If
End Function
Private Sub DrawImageToSreenDC( _
ByVal imgPath As String, _
ByVal imgAnchorRange As Range, _
Optional ByVal imgWidth As Long = 100&, _
Optional ByVal imgHeight As Long = 100& _
)
Dim uGdiInput As GdiplusStartupInput, uAnchorRangeRect As RECT
Dim gdiplusToken As LongPtr
Dim image As LongPtr
Dim hGraphics As LongPtr
Dim hDC As LongPtr
Dim lRet As Long
On Error GoTo CleanUp
uAnchorRangeRect = GetRangeRect(imgAnchorRange)
' Initialize GDI+
uGdiInput.GdiplusVersion = 1&
lRet = GdiplusStartup(gdiplusToken, uGdiInput)
If lRet <> 0& Then
MsgBox "Failed to initialize GDI+"
Exit Sub
End If
lRet = GdipLoadImageFromFile(StrPtr(imgPath), image)
If lRet <> 0& Then
MsgBox "[Image invalid or doesn't exist]" & vbLf & vbLf & _
"Make sure the Image file path in the 'Hyperlink' Function is correct."
GdiplusShutdown gdiplusToken
Exit Sub
End If
hDC = GetDC(NULL_PTR)
GdipCreateFromHDC hDC, hGraphics
With WorksheetFunction
imgWidth = .Max(100&, .Min(200&, imgWidth))
imgHeight = .Max(100&, .Min(200&, imgHeight))
End With
With uAnchorRangeRect
GdipDrawImageRectI hGraphics, image, .Left + 10&, .Bottom - 10&, imgWidth, imgHeight
End With
CleanUp:
' Cleanup Graphic Objects
GdipDisposeImage image
GdipDeleteGraphics hGraphics
ReleaseDC NULL_PTR, hDC
GdiplusShutdown gdiplusToken
End Sub
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
Static lDPI(1) As Long, hDC As LongPtr
If lDPI(0&) = 0& Then
hDC = GetDC(NULL_PTR)
lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
hDC = ReleaseDC(NULL_PTR, hDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(Points As Double, bVert As Boolean) As Long
Const POINTS_PER_INCH = 72&
PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function
Private Function GetRangeRect(ByVal Rng As Range) As RECT
Dim oPane As Pane
Set oPane = Rng.Parent.Parent.Windows(1&).ActivePane
With GetRangeRect
.Left = oPane.PointsToScreenPixelsX(Rng.Left - 1&)
.Top = oPane.PointsToScreenPixelsY(Rng.Top)
.Right = oPane.PointsToScreenPixelsX(Rng.Left + Rng.Width)
.Bottom = oPane.PointsToScreenPixelsY(Rng.Top + Rng.Height)
End With
End Function