Below is my code:
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X < 1 Or X > Label1.Width - 1 Or Y < 1 Or Y > Label1.Height - 1 Then
ActiveSheet.Shapes.Range(Array("Menu2")).Visible = msoFalse
Else
ActiveSheet.Shapes.Range(Array("Menu2")).Visible = msoTrue
End If
End Sub
This code show the shape named Menu2. I am facing a issue that when i move the mouse in speed, the Menu2 shape remains there. Is there any way to speed it up?
Thanks.
Salman
Unfortunately, the MouseMove event triggers only within few pixels around the control (the lowest I got for X and Y is -3.75). The easiest alternative I could think of is to make a big transparent label behind it and use it's MouseMove event. Initial properties setup for the second label:
Label2.BackStyle = fmBackStyleTransparent
Label2.Visible = False
Label2.Caption = ""
and then (Me is the Worksheet where the controls are):
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.Shapes("Menu2").Visible = True
Me.Label2.Visible = True ' optional so the Label2_MouseMove event triggers
Me.Application.Cursor = xlNorthwestArrow ' optional to avoid the xlWait cursor flickering
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.Shapes("Menu2").Visible = False
Me.Label2.Visible = False ' optional so the Label2_MouseMove event doesn't trigger after the first time
Me.Application.Cursor = xlDefault ' optional to restore the cursor
End Sub
Another approach can be to use GetCursorPos WinAPI - MouseMove - What is the reverse event?
Related
I am new to vba and I want to learn. Please help me with the following:
I have this application(see the picture) which I use to enter data in a worksheet (it is more easy to use compared to completing manually). It is basically an inventory management system. When I add a product in there I can choose between sale or purchase.
The next thing I would like to implement is to autofill the form whenever I want to add a sale (considering it was added as a purchase in the first place), based on a serial code for example. This would be very useful because I wont have to complete all the text boxes again when I enter a sale in the database
Do you have any ideas about how I could do this?
Kind regard,
Traian.
So, basically I shouldn't help since you have not done your research, but I did find it interesting to see if I could create such a function.
You wont be able to simply paste the code but it does work exactly as a autofill.
This is the "data" source I used for the autofill, it's looking for the left value and will autocomplete that textbox, as well as a secondary textbox with the value from column C. This would work with n numbers of autofills.
I only used 2 different fields to test this idea, disregard the labels. This is how it looked without typing anything.
As soon as you start to type, the "autofill" appears.
If you were to "hover" over the autofill, it will turn a different color, as well as all the input sheets, the input sheet also now includes the autofilled answers. if you were to "unhover"(hover over anything except the autofill) it will revert back to the second picture.
If I were to write this code again for a real project, I would change a couple of thing.
There might be leftover code from my testing, I would remove this.
I would use global variables so to avoid declaring variables more than one time.
I would name the textboxes and label in a better way.
I would complicate the textboxes with labels as to get the text to align in center.
The order of the code might not be the best for you to understand.
etc.
Here is the code:
Private Sub Autofill_Click()
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox2 = Start.Offset(BestOption, 1)
TextBox1 = Start.Offset(BestOption, 0)
Autofill.Visible = False
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Private Sub TextBox1_Change()
Dim Start As Range
Dim ValueRange As Range
Dim MatchCounter As Integer
Set Start = Sheets("sheet1").Range("B7")
Set ValueRange = Sheets("sheet1").Range("B8:B13")
If TextBox1 = "" Then
Autofill.Visible = False
Else
'Call FindClosestMatch(TextBox1)
Autofill.Visible = True
Autofill = Start.Offset(FindClosestMatch(TextBox1) + 1, 0)
End If
End Sub
Function FindClosestMatch(Entry As String) As Integer
Dim BestOption As Integer
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
Dim MyArray(6) As String
Dim i As Integer
Dim j As Integer
Dim iChar As String
Dim EntryChar As String
For i = 0 To 5
MyArray(i) = Start.Offset(i + 1, 0)
Next i
For j = 1 To Len(Entry)
EntryChar = Mid(Entry, j, 1)
For i = 0 To 5
If EntryChar = "" Then
Exit For
End If
iChar = Mid(MyArray(i), j, 1)
If iChar = EntryChar Then
BestOption = i
Else
MyArray(i) = "................."
End If
Next i
Next j
FindClosestMatch = BestOption
End Function
'hover
Private Sub Autofill_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Autofill.BackColor = &H80000002
TextBox3.BackColor = &H80000002
TextBox4.BackColor = &H80000002
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox3.Visible = True
TextBox4.Visible = True
TextBox4 = Start.Offset(BestOption, 1)
TextBox3 = Start.Offset(BestOption, 0)
End Sub
Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub UserForm_Click()
Call test
Autofill.Visible = False
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Sub test()
Autofill.BackColor = &H80000000
TextBox1.BackColor = &H80000005
TextBox2.BackColor = &H80000005
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Problem to think about:
The autofill always give the best answer, even if no good answer exist. In those cases, the best answer is the first answer in the data structure.
It is case sensitive.
One charachter wrong and you wont find your answer.
Notes:
I used 4 textboxes, number 1 and 2 are sitting on top of each other, and number 2 and 4 are on top of each other. This was done to not lose the already typed input if you accidently hovered over the autofill.
I have added drag-drop functionality to an image control that is nested inside a Frame Control in my Excel userform.
I am trying to prevent the nested image control from being moved outside of the parent control.
I was thinking of using an IF statement in a BeforeDropOrPaste event to exit all running macros (so the mousemove event) if the position is outside the range of the parent control.
How do I compare the drop location of the control to the range of the parent control?
What I think the code would look like.
Private x_offset%, y_offset%
Private Sub Image1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Dim X as Range
Dim Y as Range
Set x = parent control range
Set y = the drop location of the control this code is in
'If Y is outside or intersects X then
End
Else
End Sub
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
If Button = XlMouseButton.xlPrimaryButton Then
x_offset = X
y_offset = Y
End If
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
If Button = XlMouseButton.xlPrimaryButton Then
Image1.Left = Image1.Left + X - x_offset
Image1.Top = Image1.Top + Y - y_offset
End If
End Sub
If the location of the nested control is outside of or intersects the parent control range then return the nested control to the location it was at before the MouseMove event.
Edit - I found this code that uses a function to return a true value if the control objects overlap. http://www.vbaexpress.com/forum/showthread.php?33829-Solved-finding-if-two-controls-overlap
Function Overlap(aCtrl As Object, bCtrl As Object) As Boolean
Dim hOverlap As Boolean, vOverlap As Boolean
hOverlap = (bCtrl.Left - aCtrl.Width < aCtrl.Left) And (aCtrl.Left < bCtrl.Left + bCtrl.Width)
vOverlap = (bCtrl.Top - aCtrl.Height < aCtrl.Top) And (aCtrl.Top < bCtrl.Top + bCtrl.Height)
Overlap = hOverlap And vOverlap
End Function
How could this work for example where the Frame control is called "Frame1" and the Image control is called "Image1"?
You need to determine it the Image control border intersects its parent border.
Here is the way that I would do it:
Private Type Coords
Left As Single
Top As Single
X As Single
Y As Single
MaxLeft As Single
MaxTop As Single
End Type
Private Image1Coords As Coords
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = XlMouseButton.xlPrimaryButton Then
Image1Coords.X = X
Image1Coords.Y = Y
End If
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Const PaddingRight As Long = 4, PaddingBottom As Long = 8
Dim newPoint As Point
If Button = XlMouseButton.xlPrimaryButton Then
Image1Coords.Left = Image1.Left + X - Image1Coords.X
Image1Coords.Top = Image1.Top + Y - Image1Coords.Y
Image1Coords.MaxLeft = Image1.parent.Width - Image1.Width - PaddingRight
Image1Coords.MaxTop = Image1.parent.Height - Image1.Height - PaddingBottom
If Image1Coords.Left < 0 Then Image1Coords.Left = 0
If Image1Coords.Left < Image1Coords.MaxLeft Then
Image1.Left = Image1Coords.Left
Else
Image1.Left = Image1Coords.MaxLeft
End If
If Image1Coords.Top < 0 Then Image1Coords.Top = 0
If Image1Coords.Top < Image1Coords.MaxTop Then
Image1.Top = Image1Coords.Top
Else
Image1.Top = Image1Coords.MaxTop
End If
End If
End Sub
MoveableImage Class
Taking it a step further we can encapsulate the code using a class.
Option Explicit
Private Type Coords
Left As Single
Top As Single
x As Single
Y As Single
MaxLeft As Single
MaxTop As Single
End Type
Private Image1Coords As Coords
Public WithEvents Image1 As MSForms.Image
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
If Button = XlMouseButton.xlPrimaryButton Then
Image1Coords.x = x
Image1Coords.Y = Y
End If
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Const PaddingRight As Long = 4, PaddingBottom As Long = 8
Dim newPoint As Point
If Button = XlMouseButton.xlPrimaryButton Then
Image1Coords.Left = Image1.Left + x - Image1Coords.x
Image1Coords.Top = Image1.Top + Y - Image1Coords.Y
Image1Coords.MaxLeft = Image1.Parent.Width - Image1.Width - PaddingRight
Image1Coords.MaxTop = Image1.Parent.Height - Image1.Height - PaddingBottom
If Image1Coords.Left < 0 Then Image1Coords.Left = 0
If Image1Coords.Left < Image1Coords.MaxLeft Then
Image1.Left = Image1Coords.Left
Else
Image1.Left = Image1Coords.MaxLeft
End If
If Image1Coords.Top < 0 Then Image1Coords.Top = 0
If Image1Coords.Top < Image1Coords.MaxTop Then
Image1.Top = Image1Coords.Top
Else
Image1.Top = Image1Coords.MaxTop
End If
End If
End Sub
Userform Code
Option Explicit
Private MovableImages(1 To 3) As New MoveableImage
Private Sub UserForm_Initialize()
Set MovableImages(1).Image1 = Image1
Set MovableImages(2).Image1 = Image2
Set MovableImages(3).Image1 = Image3
End Sub
I am in the process of building an Excel based Application that builds itself dynamically at run-time based on external data.
Here is the empty userform:
Code within UserForm_Activate()
Private Sub UserForm_Activate()
Dim f As Control, i As Integer
mdMenuItems.BuildMenuItems
mdTheme.GetTheme
For Each f In Me.Controls
If TypeName(f) = "Frame" Then
i = i + 1
ReDim Preserve fra(1 To i)
Set fra(i).fraEvent1 = f
End If
Next f
End Sub
mdMenuItems.BuildMenuItems dynamically builds a series of menu items based on external data...
Code within mdMenuItems module
Option Explicit
Dim lbl() As New cMenuItem
Public myFileData As String
Public myFileValue As String
Public frmTheme As String
Sub BuildMenuItems()
Dim FileNum As Integer, i As Integer
Dim WrdArray() As String
Dim lblMenuIcon As MSForms.Label, lblMenuText As MSForms.Label, lblMenuBackground As MSForms.Label
FileNum = FreeFile()
Open Application.ThisWorkbook.Path & "\Data\MenuItems.csv" For Input As #FileNum
Do While Not EOF(FileNum)
i = i + 1
Line Input #FileNum, myFileData ' read in data 1 line at a time
WrdArray() = Split(myFileData, ",")
Set lblMenuBackground = frmTest.frmMenuBackground.Controls.Add("Forms.Label.1", "lblMenuBackground_" & i)
Set lblMenuIcon = frmTest.frmMenuBackground.Controls.Add("Forms.Label.1", "lblMenuIcon_" & i)
Set lblMenuText = frmTest.frmMenuBackground.Controls.Add("Forms.Label.1", "lblMenuText_" & i)
With lblMenuBackground
.top = 30 * i
.left = 0
.Width = 170
.Height = 30
.BackColor = RGB(255, 255, 255)
.BackStyle = fmBackStyleOpaque
.MousePointer = fmMousePointerCustom
.MouseIcon = LoadPicture(Application.ThisWorkbook.Path & "\Creative\Other\Hand.cur")
.Tag = "_006"
End With
ReDim Preserve lbl(1 To i)
Set lbl(i).lblEvent1 = lblMenuBackground
With lblMenuIcon
.Caption = Sheets("FontAwesome").Cells(WrdArray(0), 1)
.top = (30 * i) + 9
.left = 0
.Width = 30
.Height = 20
.ForeColor = RGB(0, 0, 0)
.BackStyle = fmBackStyleTransparent
.Font.Name = "FontAwesome"
.Font.Size = 14
.TextAlign = fmTextAlignCenter
.MousePointer = fmMousePointerCustom
.MouseIcon = LoadPicture(Application.ThisWorkbook.Path & "\Creative\Other\Hand.cur")
.Tag = "-021"
End With
With lblMenuText
.Caption = WrdArray(1)
.top = (30 * i) + 8
.left = 30
.Width = 90
.Height = 20
.ForeColor = RGB(0, 0, 0)
.BackStyle = fmBackStyleTransparent
.Font.Size = 12
.MousePointer = fmMousePointerCustom
.MouseIcon = LoadPicture(Application.ThisWorkbook.Path & "\Creative\Other\Hand.cur")
.Tag = "-021"
End With
Loop
Close #FileNum
End Sub
Ok, so a brief overview of whats happeing here...
I open a data file MenuItems.csv for input. I assign each line within this file to i. I then Set three individual MSForms.Label(s):
lblMenuBackground
lblMenuIcon
lblMenuText
...and build them asynchronously.
You will notice that after building the first label (lblMenuBackground), I assign a custom class event lbl(i).lblEvent1 = lblMenuBackground.
(It is important that I use ReDim Preserve correctly here so that each sequential menu item gains this custom class, and not just the last one.)
Code within cMenuItem class module
Public WithEvents lblEvent1 As MSForms.Label
Private Sub lblEvent1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim ctl As Control
For Each ctl In frmTest.frmMenuBackground.Controls
If TypeName(ctl) = "Label" Then
If Not ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6)) Then ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6))
End If
Next ctl
Me.lblEvent1.BackColor = RGB(GetB(mdTheme.frmThemeID2), GetG(mdTheme.frmThemeID2), GetR(mdTheme.frmThemeID2))
End Sub
(Please ignore the .BackColor property complexity here as it could get even more confusing, and is un-related to this question.)
After UserForm_Activate, here is the updated form:
(You may notice the use of FontAwesome icons here.)
Because I have added a custom MouseOver class event to each lblMenuBackground label, mousing over causes the .BackColor to change:
Here is my issue...
This mouse over effect is only triggered when the cursor passes over one of the three labels that make up each menu item.
lblMenuBackground
Why?
I only know how to affect the called control's properties.
Or rather...
I don't know how to affect un-called control properties from within the called control's event.
Here is the structure of each menu item:
Here is my question...
How can I affect the .BackColor of the same control from the MouseOver events of all three individual controls which make up each menu item?
Moves cursor over icon = Background colour changes
Moves cursor over text = Background colour changes
Moves cursor over background = Background colour changes
The class event needs to be assigned at build time...
ReDim Preserve lbl(1 To i)
Set lbl(i).lblEvent1 = lblMenuBackground
...for each menu item.
EndSubQuestion
__________
This logic will fundamentally lay the foundations for my interface.
For those of you who made it this far - thank you for reading!
Any help is appreciated.
Thanks,
Mr. J
You are on hooking into the events for lblMenuBackground
lbl(i).lblEvent1 = lblMenuBackground
Modify BuildMenuItems
Change
Set lbl(i).lblEvent1 = lblMenuBackground
to
Set lbl(i) = New cMenuItem
lbl(i).setControls lblMenuBackground, lblMenuIcon, lblMenuText
Modify CMenuItem Class
Public WithEvents m_lblMenuBackground As MSForms.Label
Public WithEvents m_lblMenuIcon As MSForms.Label
Public WithEvents m_lblMenuText As MSForms.Label
Public Sub setControls(lblMenuBackground As MSForms.Label, lblMenuIcon As MSForms.Label, lblMenuText As MSForms.Label)
Set m_lblMenuBackground = lblMenuBackground
Set m_lblMenuIcon = lblMenuIcon
Set m_lblMenuText = lblMenuText
End Sub
Private Sub m_lblMenuBackground_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Update
End Sub
Private Sub m_lblMenuIcon_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Update
End Sub
Private Sub m_lblMenuText_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Update
End Sub
Private Sub Update()
Dim ctl As Control
For Each ctl In frmTest.frmMenuBackground.Controls
If TypeName(ctl) = "Label" Then
If Not ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6)) Then ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6))
End If
Next ctl
Me.m_lblMenuBackground.BackColor = RGB(GetB(mdTheme.frmThemeID2), GetG(mdTheme.frmThemeID2), GetR(mdTheme.frmThemeID2))
End Sub
Private Sub framePDF_MouseMove(ByVal... )
framePDF.BackColor = &H80000012&
So, the frame's color is changing.
I can't find the event to return the color back - when the cursor is away from the frame ?
On a Userform? The Userform also has a MouseMove event that doesn't fire when you're in the Frame.
Private Sub Frame1_MouseMove(ByVal ...)
Me.Frame1.BackColor = vbRed
End Sub
Private Sub UserForm_MouseMove(ByVal ...)
Me.Frame1.BackColor = vbWhite
End Sub
will turn the frame red when you're over it and white when you're not. These events fire constantly, so use them judiciously.
In vba and VB6 there is no MouseLeave event.
The best way to achieve this is to start a timer when the mouse enters the frame.
Then in the timer code check to see if the mouse pointer is still within the bounds of the frame. If not change the colour back and stop the timer
Put this code in a module:
Public Declare Function GetCursorPos Lib "user32" (lpPoint As _
POINTAPI) As Long
Public Type POINTAPI
x As Long
y As Long
End Type
Create a timer on your form, set interval =10 Enbaled = False
Then the code looks something like this:
Private Sub frameTest_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
frameTest.BackColor = vbRed
tmrMouseLeave.Enabled = True
End Sub
Private Sub tmrMouseLeave_Timer()
Dim pt As POINTAPI
Call GetCursorPos(pt)
Dim xValue As Long, yValue As Long
xValue = pt.x * Screen.TwipsPerPixelX
yValue = pt.y * Screen.TwipsPerPixelY
If (xValue > (Me.Left + frameTest.Left)) And _
(xValue < (Me.Left + frameTest.Left + frameTest.width)) And _
(yValue > (Me.Top + frameTest.Top)) And _
(yValue < (Me.Top + frameTest.Top + frameTest.height)) Then
'we are still inside the frame
Else
'mouse is outside the frame
frameTest.BackColor = vbBlue
tmrMouseLeave.Enabled = False
End If
End Sub
Easier way: in your MouseMove event, test the X and Y arguments against the control's width and height (minus a margin, say 5) - if the mouse is in the margin, consider it a "Mouse out" and change the control's colours accordingly. No need for concurrent buttons, z-order manipulation, frames, etc.
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