I have a UserForm I've created in Excel 2010 using VBA. Controls are added to the form programmatically based on data from a particular sheet. My code adds all the controls and then determines if the form is excessively long. If it is, then the form gets set to a maximum height of 500px and scrolling is enabled.
The scrollbars appear and work as expected when clicking on the scrollbars, but the mouse scrollwheel has no effect on the scrollbars on the form.
I haven't seen any properties for enabling mouse wheel scrolling. Every article I've found on Google points to scrolling controls within a UserForm (ListBox, ComboBox, etc.) and not the UserForm itself. Other articles I've found are dated back to Excel 2003 which did not support mouse wheel scrolling out of the box.
Does anyone have any idea what's going on here?
Here is the code where I enable scrolling:
If Me.height > 500 Then
Me.ScrollHeight = Me.height
Me.ScrollBars = fmScrollBarsVertical
Me.KeepScrollBarsVisible = fmScrollBarsVertical
Me.height = 500
Me.Width = Me.Width + 12
End If
I am using Excel 2010 (32bit) on a Windows 7 64bit laptop. The same issue has appeared on other computers as well also running the same setup. I don't have access to another configuration to test this.
You can get it to work only on 32-bit Excel. The code won't compile and run at all under 64-bit Excel. Though I made (little bit more complicated) version that is compatible with both 32-bit and 64-bit, but it just don't scrolls on 64-bit, but at least compiles (please let me know if somebody needs that 64-bit compatible code).
So, you create a new module and paste there code for WinAPI calls:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 Const GWL_STYLE As Long = (-16) 'The offset of a window's style
Private Const WS_SYSMENU As Long = &H80000 'Style to add a system menu
Private Const WS_MINIMIZEBOX As Long = &H20000 'Style to add a Minimize box on the title bar
Private Const WS_MAXIMIZEBOX As Long = &H10000 'Style to add a Maximize box to the title bar
'To be able to scroll with mouse wheel within Userform
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim myForm As UserForm
Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'To handle mouse events
Dim MouseKeys As Long
Dim Rotation As Long
If Lmsg = WM_MOUSEWHEEL Then
MouseKeys = wParam And 65535
Rotation = wParam / 65536
'My Form s MouseWheel function
'=================================================================
YOUR_USERFORM_NAME_HERE.MouseWheel Rotation
'=================================================================
End If
WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, wParam, lParam)
End Function
Public Sub WheelHook(PassedForm As UserForm)
'To get mouse events in userform
On Error Resume Next
Set myForm = PassedForm
LocalHwnd = FindWindow("ThunderDFrame", myForm.Caption)
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
'To Release Mouse events handling
Dim WorkFlag As Long
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set myForm = Nothing
End Sub
And then you add a simple code to your userform... (don't forget to replace "frames_(mouseOverFrame_)") with name of your UI control you want to scroll.
Public Sub MouseWheel(ByVal Rotation As Long)
'************************************************
' To respond from MouseWheel event
' Scroll accordingly to direction
'
' Made by: Mathieu Plante
' Date: July 2004
'************************************************
Select Case frames_(mouseOverFrame_).ScrollTop - Sgn(Rotation) * 18
Case Is < 0
frames_(mouseOverFrame_).ScrollTop = 0
Case Is > frames_(mouseOverFrame_).ScrollHeight
frames_(mouseOverFrame_).ScrollTop = frames_(mouseOverFrame_).ScrollHeight
Case Else
frames_(mouseOverFrame_).ScrollTop = frames_(mouseOverFrame_).ScrollTop - Sgn(Rotation) * 18
End Select
End Sub
Because I wanted to scroll three different frames (depending on which frame is currently under mouse cursor) - I made a collection of three frames and used "MouseMove" event on each frame to assign frame number to "mouseOverFrame_" variable. So when mouse moved e.g. over 1st frame, the scroller will know which frame to scroll by having "1" inside "mouseOverFrame_" variable...
Related
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
Using Excel/VBA I have made an Excel userform containing only an InkPicture control. I have managed to load a picture (Stretch mode), make the form resizable (API calls), resize the inkpicture upon resize. This is all working perfectly well.
I also need to resize the Ink manually, as it does not scale with the InkPicture. This should also be easily implemented with InkPicture1.Renderer.ScaleTransform and it works perfectly well - most of the time!
Problem: When resizing the userform the ScaleTransform function will stop scaling in either horizontal or vertical direction - but only at specific Windows Display Scales: 125%, 175%, 200% and 225% - whereas scaling 100%, 150% and 250% works perfectly.
The change of behavior at different Windows Display Scales is weird and I have looked for driver updates and performance bottlenecks.
I am uncertain if Display Scale only applies to touchscreens.
The have the same problem on both my computers:
- Microsoft Surface Pro 6 (i5), Windows 10, Office 365 - Excel 32bit
- Lenovo Yoga (i7), Windows 10, Office 365 - Excel 64bit.
Both are touchscreens, using onboard Intel Graphics. Running on external monitors makes no change.
I have investigated:
- Windows, Office and all Drivers should be up to date
- Disabling hardware acceleration (not applicable on my computers)
- Alternative code: using inkpicture.resize event instead
- Alternative code: ScaleTransforming one direction at a time
To reproduce the error you need to...
- Create a macro enabled workbook
- Create UserForm (UserForm1)
- Add the InkPicture ActiveX control to the project
- Insert an InkPicture control (InkPicture1)
- Copy VBA code below into the project
Paste into module and run as macro:
Public Sub OpenUserForm1()
UserForm1.Show
End Sub
Paste into userform1 code:
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Dim widthBefore As Double
Dim heightBefore As Double
Private Sub UserForm_Initialize()
Me.InkPicture1.Top = 0
Me.InkPicture1.Left = 0
widthBefore = Me.InkPicture1.Width
heightBefore = Me.InkPicture1.Height
Call DrawForm
End Sub
Private Sub UserForm_Activate()
Call MakeFormMaximizable
End Sub
Private Sub UserForm_Resize()
Call DrawForm
End Sub
Private Sub DrawForm()
If Me.InsideHeight = 0 Or Me.InsideWidth = 0 Then Exit Sub
Me.InkPicture1.Width = Me.InsideWidth
Me.InkPicture1.Height = Me.InsideHeight
Dim hMultiplier As Single, vMultiplier As Single
hMultiplier = Me.InkPicture1.Width / widthBefore
vMultiplier = Me.InkPicture1.Height / heightBefore
' This function messes up!
Me.InkPicture1.Renderer.ScaleTransform hMultiplier, vMultiplier
widthBefore = Me.InkPicture1.Width
heightBefore = Me.InkPicture1.Height
End Sub
Private Sub MakeFormMaximizable()
Dim BitMask As LongPtr
Dim Window_Handle As LongPtr
Dim WindowStyle As LongPtr
Dim Ret As LongPtr
Const GWL_STYLE As Long = -16
Const WS_THICKFRAME As Long = &H40000
Const MAX_BOX As Long = &H10000
Box_Type = MAX_BOX
Window_Handle = GetForegroundWindow()
WindowStyle = GetWindowLongPtr(Window_Handle, GWL_STYLE)
BitMask = WindowStyle Or Box_Type Or WS_THICKFRAME
Ret = SetWindowLongPtr(Window_Handle, GWL_STYLE, BitMask)
Ret = DrawMenuBar(Window_Handle)
End Sub
To get Wanted/Expected behavior:
- Set Graphic Display Scale to 100% (followed by logout/login)
- Open Excel workbook / Open Userform
- Draw ink on userform
- Resizing the userform will be completely smooth and seamless - perfect!
To get Weird behavior:
- Set Graphic Display Scale to 200% (followed by logout/login)
- Open Excel workbook / Open Userform
- Draw ink on userform
- When resizing the userform the drawn ink no longer follows. It either only scales in one direction, or scales in a direction that is not being scaled.
I hope someone can reproduce the same error/behavior, has had similar experience, has an idea or ideally a fix.
Thanks a lot.
I found a work around. You need to ignore the calculations the InkPicture Control makes on its Rendering Transform Matrix and instead use the Inkpicture.SetViewTransform and the InkTransform.SetTranform functions manually. The code is quite clear and now it will make your UserForm, InkPicture and your Ink resize coordinated and smoothly across all display settings (those tested anyways).
However, the scale factor will not be consistent across display settings - you need to calibrate the coordinate systems! I have done this by creating an initial scaling factor with the function Inkpicture.GetViewTransform. This needs to be called from Form_Init and I have wrapped the code in function GetInitScale in the code below.
Here is the full modified code except UserForm1.show:
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
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 GetDeviceCaps Lib "Gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Const TWIPSPERINCH = 1440
Dim widthBefore As Double, heightBefore As Double
Dim xInitScale As Double, yInitScale As Double
Private Sub UserForm_Initialize()
widthBefore = Me.InkPicture1.Width
heightBefore = Me.InkPicture1.Height
Me.InkPicture1.Top = 0
Me.InkPicture1.Left = 0
Call GetInitScale
Call DrawForm
End Sub
Private Sub UserForm_Activate()
Call MakeFormMaximizable
End Sub
Private Sub UserForm_Resize()
Call DrawForm
End Sub
Private Sub DrawForm()
Me.InkPicture1.Width = Me.InsideWidth
Me.InkPicture1.Height = Me.InsideHeight
Call ScaleInk
End Sub
Private Sub GetInitScale()
Dim aTransform As New InkTransform
Dim eM11 As Single, eM12 As Single, eM21 As Single, eM22 As Single, eDx As Single, eDy As Single
' Remember initial transform to ensure robustness for diffrent display settings
Me.InkPicture1.Renderer.GetViewTransform aTransform
aTransform.GetTransform eM11, eM12, eM21, eM22, eDx, eDy
xInitScale = eM11
yInitScale = eM22
End Sub
Private Sub ScaleInk()
Dim aTransform As New InkTransform
Dim eM11 As Single, eM22 As Single
' Set transformation matrix manually
eM11 = xInitScale * Me.InkPicture1.Width / widthBefore
eM22 = yInitScale * Me.InkPicture1.Height / heightBefore
' Set new Transform
aTransform.SetTransform eM11, 0, 0, eM22, 0, 0
Me.InkPicture1.Renderer.SetViewTransform aTransform
End Sub
Private Sub MakeFormMaximizable()
Dim BitMask As LongPtr
Dim Window_Handle As LongPtr
Dim WindowStyle As LongPtr
Dim Ret As LongPtr
Const GWL_STYLE As Long = -16
Const WS_THICKFRAME As Long = &H40000
Const MAX_BOX As Long = &H10000
Box_Type = MAX_BOX
Window_Handle = GetForegroundWindow()
WindowStyle = GetWindowLongPtr(Window_Handle, GWL_STYLE)
BitMask = WindowStyle Or Box_Type Or WS_THICKFRAME
Ret = SetWindowLongPtr(Window_Handle, GWL_STYLE, BitMask)
Ret = DrawMenuBar(Window_Handle)
End Sub
Hope this becomes useful to someone. It certainly was to me :-)
/Cheers
I have a code to perform data entry from an excel sheet to a website which opens in google chrome. The code is working absolutely fine. I just want both the excel and chrome windows positioned on top side by side while macro is running. The excel window gets positioned to left perfectly however there is no impact on chrome window. I couldn't figure out the solution after googling a lot. Chrome and data entry is being controlled by Selenium.
'This part has code to import window resizing functions.
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function MoveWindow Lib "user32" ( _
ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Sub Selenuim_Upload()
Dim test1 As Long, test2 As Long
test1 = Timer
Dim obj As New WebDriver
obj.Start "chrome", ""
obj.Get "https://csa.xyz.com/"
obj.FindElementById("ContentPlaceHolder1_ddlUserProfile").SendKeys ("Collector")
obj.FindElementById("ContentPlaceHolder1_btn_login").Click
obj.Get "https://csa.xyz.com/Collector_view.aspx/Default.aspx/"
'------------------------------------------------------------------------
' This part calculates window sizes and moves Excel window to left and IE window to right.
Dim hWnd As Long
Dim R As RECT, LW As RECT, RW As RECT
'Get the size of the deskop
If GetWindowRect(GetDesktopWindow, R) = 0 Then Exit Sub
'Calculate the left and right side
LW = R
LW.Right = R.Left + (R.Right - R.Left) / 2
RW = R
RW.Left = R.Right - (R.Right - R.Left) / 2
'Move Excel to the left
hWnd = FindWindow("XLMAIN", vbEmpty)
With LW
MoveWindow hWnd, .Left, .Top, .Right - .Left, .Bottom - .Top, True
End With
BringWindowToTop hWnd
'Move Chrome to the right
hWnd = FindWindow("Chrome_WidgetWin_1", vbEmpty)
With RW
MoveWindow hWnd, .Left, .Top, .Right - .Left, .Bottom - .Top, True
End With
BringWindowToTop hWnd
'------------------------------------------------------------------------
'Select Invoice Number in Serch By box
obj.FindElementById("ContentPlaceHolder1_ddlSearch").SendKeys ("Inv Number")
Range("A1").Select
'REST OF THE CODE CONTINUES FROM HERE
I have figured out the solution. Thanks to this thread link . I used winlister (by nirsoft) to find the window title of that website that the macro was opening. Then replaced that with vbEmpty in hWnd = FindWindow("Chrome_WidgetWin_1", vbEmpty) so the final line of code is like hWnd = FindWindow("Chrome_WidgetWin_1", "https://csa.xyz.com/Collector_view.aspx/Default.aspx/ - Google Chrome") .
Now the code is able to arrange both excel and chrome window side by side.
Here's what I want to achieve:
From the main workbook, display a userform. (this is easy)
While initializing the userform, open a secondary workbook. (this is easy)
Once the secondary workbook is open, set its top, left, width and height properties such that the workbook appears precisely positioned over a Frame1 control on the userform.
The result of all of this is that the secondary workbook appears as a virtual spreadsheet control on the form.
I have be iterating with various means of determining the screen coordinates of the form and the Frame1 control without a final result. Various Win32 APIs seem to get to parts of it, e.g., GetSystemMetrics, GetDeviceCaps, FindWindow, WindowFromPoint, etc.
A complicating factor is that I won't know that screen resolution of the operating environment. The task seems akin to translating French into Russian, then into Latin, then into Aztec, and finally into binary. I need a Rosetta Stone. But alas.
Anyone got that Rosetta Stone?
Thanks,
Bob
PS. Note that OWC11 is not a satisfactory option for a number of reasons, including it's limitation in displaying conditional cell formatting, availability of some necessary Excel functions and because it is deprecated.
To get the screen resolution of the operating environment, you can use the code:
Private Declare Function GetSystemMetrics32 Lib "User32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Const LOGPIXELSX = 88 'Might be wrong as online says 96
Private Const LOGPIXELSY = 96
Private Const POINTS_PER_INCH As Long = 72
Public Function PointsPerPixel() As Double
Dim hDC As Long
Dim lDotsPerInch As Long
hDC = GetDC(0)
lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
ReleaseDC 0, hDC
End Function
Public Function PixelsPerPoint() as Double
Dim hDC As Long
Dim lDotsPerInch As Long
hDC = GetDC(0)
lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
PixelsPerPoint = lDotsPerInch / POINTS_PER_INCH
ReleaseDC 0, hDC
End Function
Function ScreenRes() as Double()
Dim resolution(2) as Double
resolution(0) = GetSystemMetrics32(0) ' width in points
resolution(1) = GetSystemMetrics32(1) ' height in points
ScreenRes = Resolution
End Function
To get the Resolution use ScreenRes(). Then you can find the forms location using formName.left and formName.top, and I believe it is a point-based location. You could have the code either convert this to Pxl's, or convert your screen size to points. Then to move the excel workbook you can use Application.left and Application.top, and I'm pretty sure this is in points as well.
If you want to format it nicer for the screen, you can also use the Application.width and Application.height in conjunction with formName.width and formName.height. You can check if the bounds of the form are off screen by using if (formName.left + formName.width) > (PixelsToPoint *(ScreenRes)(0)) and (formName.left > 0) and a similar form for height.
There is likely errors in my code as I haven't checked it in VBA but hopefully this is a start to what you need. If someone wants to make an edit to my code I would be extremely grateful, and hopefully what I have said helps as your question was slightly vague.
With the Top and Left arguments for this function is there a Centre screen option, or will it always be a number?
I'm using this instead of a regular inputbox as it handles the cancel event better but it always appears in the bottom right of the screen which is less than helpful :/
There is no center screen option. You'd have to calculate it. But, assuming you are using Excel 2007 or later, there's another issue...
This was news to me, but in googling and testing I see that in Excel 2007 and 2010 Application.Inputbox reverts to its last position, disregarding the Top and Left settings. This problem seems to persist even if a new Inputbox is called from a new worksheet. When I try it in XL 2003 it works correctly, and the Inputbox is placed at the correct left and right coordinates.
You can maybe just drag the Inputbox where you want and then save. Unless somebody drags it later, it will re-open in the same place.
Here's a link to a solution that worked for somebody to bring back the correct behavior, and also addresses centering the inputbox. It does require API calls, so save your work before you try it.
EDIT - Per JMax's comment, here's the code from the link above. It's by a user called KoolSid on the vbforums.com site:
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" (ByVal idHook As Long, _
ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId 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
'~~> Handle to the Hook procedure
Private hHook As Long
'~~> Hook type
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
'~~> SetWindowPos Flags
Private Const SWP_NOSIZE = &H1 '<~~ Retains the current size
Private Const SWP_NOZORDER = &H4 '<~~ Retains the current Z order
Dim InputboxTop As Long, InputboxLeft As Long
Sub TestInputBox()
Dim stringToFind As String, MiddleRow As Long, MiddleCol As Long
hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, 0, GetCurrentThreadId)
'~~> Get the center cell (keeping the excel menus in mind)
MiddleRow = ActiveWindow.VisibleRange.Rows.Count / 1.2
'~~> Get the center column
MiddleCol = ActiveWindow.VisibleRange.Columns.Count / 2
InputboxTop = Cells(MiddleRow, MiddleCol).Top
InputboxLeft = Cells(MiddleRow, MiddleCol).Left
'~~> Show the InputBox. I have just used "Sample" Change that...
stringToFind = Application.InputBox("Sample", _
"Sample", "Sample", InputboxLeft, InputboxTop, , , 2)
End Sub
Private Function MsgBoxHookProc(ByVal lMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = HCBT_ACTIVATE Then
'~~> Change position
SetWindowPos wParam, 0, InputboxLeft, InputboxTop, _
0, 0, SWP_NOSIZE + SWP_NOZORDER
'~~> Release the Hook
UnhookWindowsHookEx hHook
End If
MsgBoxHookProc = False
End Function
You can test the regular inputbox to see if cancel was pressed, and it has the extra benifit of always being centered. Just use StrPtr(variable) = 0 to test it. Simple!
Another way to avoid a user hitting OK with nothing typed is to add a default value inside the input box to start with, that way you know that if it returns an empty string, it's most likely due to the cancel button being pressed.
StrPtr will return a 0 if cancel was selected (also returns 0 for vbNullString, btw). Please note that StrPtr work in VB5, VB6, and VBA, but since it's not officially supported, it could be rendered unusuable years down the line. I highly doubt they'd get rid of it but it's worth considering if this is an application you plan to distribute.
Sub CancelTest()
Dim temp As String
temp = InputBox("Enter your name", "Cancel Test")
If StrPtr(temp) = 0 Then
' You pressed cancel
Else
If temp = "" Then
'You pressed OK but entered nothing
Else
'Do your thing
End If
End If
End Sub
Some more info on strptr:
StrPtr(S) returns a pointer to the actual string data currently stored in S. This is what you need when passing the string to Unicode API calls. The pointer you get points to the Datastring field, not the Length prefix field. In COM terminology, StrPtr returns the value of the BSTR pointer. (from the fantastic site: http://www.aivosto.com/vbtips/stringopt2.html)
' assume normal screen else go through GetDeviceCaps(hDCDesk, LOGPIXELSX) etc etc
' 1440 twips / inch pts / pix = 3/4 inch 100 pts
' so twips / pixel = 15
Sub GetRaXy(Ra As Range, X&, Y&) ' in twips
Dim ppz!
ppz = ActiveWindow.Zoom / 75 ' zoom is % so 100 * 3/4 =>75
' only the pixels of rows and columns are zoomed
X = (ActiveWindow.PointsToScreenPixelsX(0) + Ra.Left * ppz) * 15
Y = (ActiveWindow.PointsToScreenPixelsY(0) + Ra.Top * ppz) * 15
End Sub
Function InputRealVal!(Optional RaTAdd$ = "K11")
Dim IStr$, RAt As Range, X&, Y&
Set RAt = Range(RaTAdd)
GetRaXy RAt, X, Y
IStr = InputBox(" Value ", "ENTER The Value ", 25, X, Y)
If StrPtr(IStr) = 0 Then
MsgBox "Cancel Pressed"
Exit Function
End If
If IsNumeric(IStr) Then
InputRealVal = CDec(IStr)
Else
MsgBox "Bad data entry"
Exit Function
End If
End Function