VBA Place Userform Next to Selected Range - excel

I need to place a userform next to a selected cell. Here's my code. Excel 2013.
In the userform module:
Private rangePosition As Range 'Property passed to form to set position based on range
'Set userform position to right of range
Property Let PositionToRange(rangeInput As Range)
Set rangePosition = rangeInput
Me.Left = rangePosition.Left + rangePosition.Width + 30
Me.Top = rangePosition.Top + Application.CommandBars("Ribbon").Height + 27
End Property
In a standard module:
userform.PositionToRange = Selection '(or some specified range)
userform.Show
Okay, great. So at first this seemed to do the trick. However, it only seems to work in the standard view when Excel first loads, with the first 30 rows or so. However, if you try to use it on, say, row 4000, or even 40, it places the userform WAY off the screen. Excel doesn't seem to take the position of the screen into account. To see what I mean, try using the code above to place a userform next to cell A1. Then scroll down so A1 is no longer on the screen and run the code again. It puts the userform in exactly the same place, as if you were still scrolled up in the original position.
Is there an attribute I can use other than range.Left, etc to place the userform relative to where the range is on the screen? Or do I need to do some weird voodoo crap where I figure out the position of the scroll bar and find the position of the cell relative to that, after factoring in the rotational force of the earth and relative distance from the sun, of course?
Oh, Microsoft...

You can adjust the position of the form when it is scrolled by using the
ActiveWindow.VisibleRange.Top &
ActiveWindow.VisibleRange.Left
Use this it will work in all cases
Me.Left = ActiveCell.Left + ActiveCell.Width - ActiveWindow.VisibleRange.Left
Me.Top = ActiveCell.Top - ActiveWindow.VisibleRange.Top

By declaring the GetDeviceCaps , GetDC , ReleaseDC
functions , I repositioned the userform next to each the clicked
activecell .(The template is checked in 32-bit and 64-bit Excel versions)
Type POINTAPI
X As Long
Y As Long
End Type
#If VBA7 Then
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
Dim hDc As LongPtr
#Else
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
Dim hDc As Long
#End If
...
Source codes , sample file link

Related

Changing background color for Status Bar of Excel

I'm using Excel 2016 (Office Theme:Colorful) and unfortunately when I write some code with a user defined text for displaying in status bar, the status bar changes its background color to dark green instead of remaining in vbButtonFace (&H8000000F). The result is an unreadable status bar text message, considered that the font color remains dark grey as expected.
I know it directly can't be done by VBA (please, don't suggest to me of changing Office theme... it's not an option!)
Googling around I found some code which uses API functions SendMessage and GetSysColor calls that I rearranged as follow:
#If VBA7 Then
Public 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
Public Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#Else
Public 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
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#End If
Private Const CCM_FIRST As Long = &H2000 'Common Control Messages
Private Const CCM_SETBKCOLOR As Long = (CCM_FIRST + 1)
Private Const PBM_SETBKCOLOR As Long = CCM_SETBKCOLOR 'Progress Bar Messages
Private Const COLOR_BTNFACE = &H8000000F
#If VBA7 Then
Public Sub SetStatusBackColour(hwndStatBar As LongPtr, ByVal clrref As Long)
Call SendMessage(hwndStatBar, PBM_SETBKCOLOR, 0&, ByVal clrref)
End Sub
#Else
Public Sub SetStatusBackColour(hwndStatBar As Long, ByVal clrref As Long)
Call SendMessage(hwndStatBar, PBM_SETBKCOLOR, 0&, ByVal clrref)
End Sub
#End If
Public Function EvalCol(ByVal inCol As Long) As Long ' Returns the RGB of a long colour value (System colour aware)
If ((inCol And &HFFFFFF00) = &H80000000) Then EvalCol = GetSysColor(inCol And &HFF) Else EvalCol = inCol
End Function
Private Sub Test()
Call SetStatusBackColour(StatusBar1.hwnd, EvalCol(vbButtonFace))
'Call SetStatusBackColour(StatusBar1.hwnd, COLOR_BTNFACE) 'without GetSysColor API function call
End Sub
Now the problem is... How can I find the hwnd of the Excel Status Bar?
Obviously, if this approach doesn't apply anymore or a different approach can be used instead, please tell me!
You may work around this issue by updating screen before setting the value of status bar then turning it back to False.
For example:
Application.ScreenUpdating = True
Application.StatusBar = "Transferring Records: " & I & " of " & X & " completed..."
Application.ScreenUpdating = False

Excel 2016: Use a control form to cover up the Excel ribbon while a macro is running

I have a macro which does manipulations on the ribbon. Because it looks awkward for the user to see rapid automated actions on the ribbon, I would like to cover up the ribbon while the macro is running with a control form or some sort of a filled rectangle. Can you please suggest a solution for that?
EDIT: I tried creating a modeless form and positioned it over the ribbon. Unfortunately, as the macro runs, the actions still flicker through and their z-order seems to overpower that of the user form. I think I've exhausted everything considering this other post of mine, but who knows maybe there's something out there that will do the trick.
EDIT 2: As you can see in the GIF above, the macro actions still flicker through over the modeless user form even after setting the window position as top most, as suggested. I also tried showing and re-positioning the form after expanding the ribbon, but that causes a run-time error as the UI automation framework is not able to track-down the UI elements it needs to operate on next.
To display a userform over a certain portion of the screen to cover something while code will do something to the ribbon behind it, we'll need a modeless userform.
As opposed to a modal userform, the modeless userform has the following advantage since it is a seperate window: It can be displayed on top of the Excel window while the Excel Window keeps the focus.
Let's say the name of the userform is frmCoverScreen. To invoke it as a modeless userform, we'd do:
frmCoverScreen.Show vbModeless
Now, we need to use the SetWindowPos function from the Windows API in order to make the form appear on top of the Excel Window at all times. We're also going to need the FindWindow function to get the window handle of our userform. You can include the following code to declare the function in your project (top of module):
#If VBA7 Then
'VBA version 7 compiler, therefore >= Office 2010
'PtrSafe means function works in 32-bit and 64-bit Office
'LongPtr type alias resolves to Long (32 bits) in 32-bit Office, or LongLong (64 bits) in 64-bit Office
Public 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 uFlags As Long) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
#Else
'VBA version 6 or earlier compiler, therefore <= Office 2007
Public 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 uFlags As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
You can then include the following constants and variable that will be used inside the SetWindowPos function:
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_TOPMOST = -1
#If VBA7 Then
Public WinHandle As LongPtr
#Else
Public WinHandle As Long
#End If
Hence, we can now get the window handle of our userform:
If Val(Application.Version) >= 9 Then
WinHandle = FindWindow("ThunderDFrame", frmCoverScreen.Caption)
Else
WinHandle = FindWindow("ThunderXFrame", frmCoverScreen.Caption)
End If
And now having the handle, we can make the userform window appear on top of Excel at all times using the following:
SetWindowPos WinHandle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
Then we only need to set the .Top , .Left , .Width and .Height properties of the userform to make sure it covers the part of the screen we need to cover.
Finally, when we no longer need to cover the screen, we can simply unload the form:
Unload frmCoverScreen

How to get the border sizes of a userform?

I have a userform (userform1) with several controls. One control is a command button which will open a second userform (userform2).
I want that userform2 opens immediately bellow the button and centered with it.
To have the same behavior regardless the system/themes definitions for Windows, I need to know the sizes of the borders of userform1.
After digging during 3 days, I used API functions GetWindowRect and GetWindowClient. With these two API routines, I can find the TOTAL sizes of the horizontal borders (upper plus lower) and of the vertical borders (left plus right), but not them individually.
For vertical borders, it is common sense that they will have the same thickness (width) — in fact, I’ve never seen a window with different left and right borders. So, the solution is to divide by 2 the total size. However, for horizontal borders this cannot be used, since the upper border is usually thicker that the lower.
Eventually, I found a workaround for the problem, but it cannot be applied always. That is, if there is a frame control inside userform1, then the API function GetWindowRect can be used to find the “absolute” coordinates of the frame, i.e., referred to the screen, not to userform1. Then, the upper border size is given by: frame.top_Absolute – (Userform1.top_Absolute - frame.top_RelativeToUserform1).
The problem of this approach is, userforms have not frame controls always. On the other hand, not all controls have a “rectangle” property; therefore, GetWindowRect cannot be used for all controls.
Question: is there a “direct” way to find the size of the borders of a userform?
Code
In an ordinary module:
Option Explicit
'API Declarations
#If VBA7 Then
Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
Declare Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type BorderSize
TopHeight As Long
LeftWidth As Long
BottomHeight As Long
RightWidth As Long
End Type
Public FormBorders As BorderSize
'To determine the sizes of the borders
Public Sub GetFormBorders(ByVal FormHandler As Long, ByVal FrameHandler As Long)
Dim rectForm As udtRECT
Dim rectFrame As udtRECT
Dim rectClientForm As udtRECT
Dim Trash As Long
Trash = GetWindowRect(FormHandler, rectForm)
Trash = GetWindowRect(FrameHandler, rectFrame)
Trash = GetClientRect(FormHandler, rectClientForm)
FormBorders.TopHeight = ConvertPixelsToPoints(rectFrame.Top - rectForm.Top, "Y") - frmFlyschGSI.fraRockProp.Top 'userform1.frame.top
FormBorders.LeftWidth = ConvertPixelsToPoints(rectFrame.Left - rectForm.Left, "X") - frmFlyschGSI.fraRockProp.Left
FormBorders.BottomHeight = ConvertPixelsToPoints(rectForm.Bottom - rectForm.Top, "Y") - FormBorders.TopHeight - _
ConvertPixelsToPoints(rectClientForm.Bottom - rectClientForm.Top, "Y")
FormBorders.RightWidth = ConvertPixelsToPoints(rectForm.Right - rectForm.Left, "X") - FormBorders.LeftWidth - _
ConvertPixelsToPoints(rectClientForm.Right - rectClientForm.Left, "X")
Debug.Print FormBorders.TopHeight, FormBorders.LeftWidth, FormBorders.BottomHeight, FormBorders.RightWidth
End Sub
'To convert pixels to points
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, ByVal sXorY As String) As Single
'Credits to: https://bettersolutions.com/vba/userforms/positioning.htm
Dim hDC As Long
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
End Function
'In the Userform code sheet:
Option Explicit
Private Sub UserForm_Initialize()
'Some code here
If Me.Visible = False Then
Call GetFormBorders(FindWindow(vbNullString, frmFlyschGSI.Caption), frmFlyschGSI.fraRockProp.[_GethWnd])
End If
'More code here
End Sub
Private Sub cmdMiHarder_Click()
Dim FrameBorder As udtRECT
Dim Trash As Long
Dim sngTopBorder As Single
Dim sngLeftBorder As Single
'Some code here
Trash = GetWindowRect(Me.fraRockProp.[_GethWnd], FrameBorder)
sngTopBorder = ConvertPixelsToPoints(FrameBorder.Top, "Y") - (Me.Top + Me.fraRockProp.Top)
sngLeftBorder = ConvertPixelsToPoints(FrameBorder.Left, "X") - (Me.Left + Me.fraRockProp.Left)
'More code here
End Sub
Logic:
Show Userform1 as modeless. This is required so that Userform2 can be shown as modeless
Show Userform2 as modeless. This is required so that Userform2 can be moved
Move Userform2 to the relevant position
New Position Calculations:
Can be much better explained with the below image
In a Module:
Option Explicit
Sub Sample()
UserForm1.Show vbModeless
End Sub
In Userform1 code area:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) 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 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 Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Type POINTAPI
x As Long
y As Long
End Type
Private Const HWND_TOP = 0
Private Const SWP_NOSIZE = &H1
Private Sub CommandButton1_Click()
RepositionForm UserForm2, CommandButton1
End Sub
Public Sub RepositionForm(f As Object, c As Object)
Dim P As POINTAPI
Dim meHwnd As Long, hwnd As Long
meHwnd = FindWindow(vbNullString, Me.Caption)
P.x = (c.Left - (f.Width / 4)) / PointsPerPixelX
P.y = (c.Top + c.Height) / PointsPerPixelY
'~~> The ClientToScreen function converts the client coordinates
'~~> of a specified point to screen coordinates.
ClientToScreen meHwnd, P
UserForm2.Show vbModeless
'~~> Get Handle of Userform2
hwnd = FindWindow("ThunderDFrame", "UserForm2")
'~~> Move the form to relevant location
SetWindowPos hwnd, HWND_TOP, P.x, P.y, 0, 0, SWP_NOSIZE
End Sub
Private Function PointsPerPixelX() As Double
Dim hDC As Long
hDC = GetDC(0)
PointsPerPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC 0, hDC
End Function
Public Function PointsPerPixelY() As Double
Dim hDC As Long
hDC = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
End Function
Screenshot
I can answer to my own question now after reading Siddharth Rout’s code. The key is to use the ClientToScreen API function to find the “screen” coordinates of the upper left corner of the client window (of the userform).
I am leaving here the code, in case someone needs to know the border sizes of a userform.
In a ordinary module:
Option Explicit
'
'API Declarations
'
#If VBA7 Then
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnD As Long, ByRef lpPoint As PointAPI) As Long
#Else
Declare Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hWnD As Long, ByRef lpPoint As PointAPI) As Long
#End If
'
Public Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'
Public Type PointAPI
x As Long
y As Long
End Type
'
Public Type BorderSize
TopHeight As Single
LeftWidth As Single
BottomHeight As Single
RightWidth As Single
End Type
'
' To determine the sizes of the borders
'
Public Function FormBorders(ByVal FormHandler As Long) As BorderSize
'
' Credits to Siddharth Rout for the usage of ClientToScreen API function in this context.
'
Dim rectWindow As udtRECT
Dim rectClient As udtRECT
Dim P As PointAPI
Dim VerBorders As Single
Dim HorBorders As Single
Dim Trash As Long
'
Trash = GetWindowRect(FormHandler, rectWindow)
Trash = GetClientRect(FormHandler, rectClient)
'
' Sets the upper left corner of the "client" window...
P.x = 0
P.y = 0
Trash = ClientToScreen(FormHandler, P) '...and gets its screen coordinates.
'
' Total dimensions of the borders in points, after converting pixels to points:
VerBorders = ConvertPixelsToPoints((rectWindow.Right - rectWindow.Left) - (rectClient.Right - rectClient.Left), "X")
HorBorders = ConvertPixelsToPoints((rectWindow.Bottom - rectWindow.Top) - (rectClient.Bottom - rectClient.Top), "Y")
'
' Now the individual borders, one by one, in points:
FormBorders.TopHeight = ConvertPixelsToPoints(P.y - rectWindow.Top, "Y")
FormBorders.BottomHeight = HorBorders - FormBorders.TopHeight
FormBorders.LeftWidth = ConvertPixelsToPoints(P.x - rectWindow.Left, "X")
FormBorders.RightWidth = VerBorders - FormBorders.LeftWidth
'
Debug.Print FormBorders.TopHeight, FormBorders.LeftWidth, FormBorders.BottomHeight, FormBorders.RightWidth
'
End Function
'
'To convert pixels to points
'
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, ByVal sXorY As String) As Single
'
'Credits to: https://bettersolutions.com/vba/userforms/positioning.htm
'
Dim hDC As Long
'
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
'
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
'
End Function
In the code sheet of the userform:
Option Explicit
Private Sub UserForm_Initialize()
'
Dim MeBorders As BorderSize
MeBorders = FormBorders(FindWindow(vbNullString, Me.Caption))
Debug.Print MeBorders.TopHeight, MeBorders.LeftWidth, MeBorders.BottomHeight, MeBorders.RightWidth
End Sub

Looking To Get The Colour Of A Picture In Excel

I have a requirement where I need to get the colour of a picture in one of the cells.
Ideally I would like to do this via a piece of VBA Code, but I would be happy enough with a formula if one exists.
Please see attached screenshot.
In this scenario, I would like one of the following options
Replace Each of the Black Box Pictures with False and Replace the White Box Pictures with True
Have a formula that I could type into Column D which would describe the colour of the Picture.
Any help greatly appreciated.
Thanks,
Mark
Screenshot Of Example
This is a beast since we have to hit up a bunch of windows libraries to get the absolute position of the top-left of a cell, grab the pixel, figure out the color, and dump that back into the workbook.
I just did an "Assign Macro" to a picture in Cell D2 so when I click on it, this will stick that same color in Cell A1. You can monkey around with it to get it to do what you need, but all the necessary junk is here to do it.
#If VBA7 Then
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) 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 GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Function ScreenDPI(bVert As Boolean) As Long
'in most cases this simply returns 96
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&) 'horz
lDPI(1) = GetDeviceCaps(lDC, 90&) 'vert
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Private Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window
'requires additional code to verify the range is visible
'etc.
Set wnd = rng.Parent.Parent.Windows(1)
With rng
rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) _
+ wnd.PointsToScreenPixelsX(0)
rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) _
+ wnd.PointsToScreenPixelsY(0)
rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) _
+ rc.Left
rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) _
+ rc.Top
End With
End Sub
Sub CellColor(cellRange As Range)
Dim lColour As Long
Dim lDC As Variant
lDC = GetWindowDC(0)
'Grab the pixel that we will use to determine the color
Dim rc As RECT
Dim xPos As Integer
Dim yPos As Integer
Call GetRangeRect(cellRange, rc)
xPos = rc.Left
yPos = rc.Top
lColour = GetPixel(lDC, xPos, yPos)
Debug.Print xPos, yPos, lColour
Sheet1.Range("a1").Interior.Color = lColour
End Sub
Sub Picture1_Click()
CellColor Sheet1.Range("D2")
End Sub

Can I disable a VBA UDF calculation when the Insert Function/Function Arguments dialogs are displayed?

I have an Excel VBA UDF that performs some expensive calculations. Currently, Excel tries to run the function when the user clicks on the Insert Function dialog (the 'fx' button next to the formula bar), and this causes problems in my code.
Is there a way I can set the function to not calculate when the user has the Insert Function dialog (or the Function Arguments dialog, which is what shows up when the function name is already provided) open? I'd like to have the function only run when the user enters the formula in a cell or refreshes the sheet.
try adding this code to the start of your function:
If (Not Application.CommandBars("Standard").Controls(1).Enabled) Then Exit Function
It will quit your UDF if the function wizard is being used
There is one circumstance in which the "CommandBars" solution provided by Charles Williams fails, falsely indicating that the function wizard is active when it's not.
It happens when you open a comma-separated text file in Excel in which case all open Excel workbooks are recalculated, even if Excel calculation is set to manual. That's quite disruptive if you have workbooks open with slow-to-calculate VBA UDFs that use the CommandBars test to exit early if the Wizard is thought to be active.
Charles further suggests that the Windows API can be used as an alternative approach. I've not been able to find such code elsewhere so here's my attempt to implement Charles' suggestion.
Tested only on English-language 64-bit Excel 365.
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As LongPtr, ByRef lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Const GW_HWNDNEXT = 2
Function FunctionWizardActive() As Boolean
Dim ExcelPID As Long
Dim lhWndP As LongPtr
Dim WindowTitle As String
Dim WindowPID As Long
Const FunctionWizardCaption = "Function Arguments" 'This won't work for non English-language Excel
If TypeName(Application.Caller) = "Range" Then
'The "CommandBars test" below is usually sufficient to determine that the Function Wizard is active,
'but can sometimes give a false positive. Example: When a csv file is opened (via File Open) then all
'active workbooks are calculated (even if calculation is set to manual!) with
'Application.CommandBars("Standard").Controls(1).Enabled being False
'So apply a further test using Windows API to loop over all windows checking for a window with title "Function Arguments", checking also the process id.
If Not Application.CommandBars("Standard").Controls(1).Enabled Then
ExcelPID = GetCurrentProcessId()
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
WindowTitle = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, WindowTitle, Len(WindowTitle)
WindowTitle = Left$(WindowTitle, Len(WindowTitle) - 1)
If WindowTitle = FunctionWizardCaption Then
GetWindowThreadProcessId lhWndP, WindowPID
If WindowPID = ExcelPID Then
FunctionWizardActive = True
Exit Function
End If
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End If
End If
End Function
With that function available, you can amend your slow VBA UDFs with the code:
If FunctionWizardActive() Then Exit Function

Resources