I have created a custom shape to use as a Macro button in Excel. Initially, I was using the default Excel macro button, but wanted to make the spreadsheet look more modern. I have achieved what I was seeking in that regard, but now the buttons do not provide any feedback when you click them- they just load the Macro. With the original buttons, pressing them would provide a depression effect. I would like to simulate this effect with the new shape.
After searching solutions on the internet, I found one that worked.. once. It simulated a button click for a fraction of a second and loaded the macro. After the first use, it stopped working all together. I tried creating a new subroutine, but it did not help. I also added a sleep step at the recommendation of the site I found it on, and it did not have any effect either. Here's the code I am using:
Sub SimulateButtonClick2()
Dim vTopType As Variant
Dim iTopInset As Integer
Dim iTopDepth As Integer
'Record original button properties
With ActiveSheet.Shapes(Application.Caller).ThreeD
vTopType = .BevelTopType
iTopInset = .BevelTopInset
iTopDepth = .BevelTopDepth
End With
'Button Down
With ActiveSheet.Shapes(Application.Caller).ThreeD
.BevelTopType = msoBevelSoftRound
.BevelTopInset = 24
.BevelTopDepth = 8
End With
Application.ScreenUpdating = True
Sleep 250
Application.ScreenUpdating = True
'Button Up - set back to original values
With ActiveSheet.Shapes(Application.Caller).ThreeD
.BevelTopType = vTopType
.BevelTopInset = iTopInset
.BevelTopDepth = iTopDepth
End With
Call checker
End Sub
I am assigning this macro to the button and calling the macro I need using "Call checker" at the end.
Thank you!
EDIT: updated to add alternative approach to pause until mouse button is released
This worked fine for me, using a loop with Timer and Doevents:
'add the 64-bit version if you need to support that...
Private Declare Function GetAsyncKeyState Lib "User32" (ByVal vKey As Long) As Long
Sub Tester()
SimulateButtonClick ActiveSheet.Shapes(Application.Caller)
Debug.Print "clicked!"
End Sub
'is the left mouse button down?
Function MouseIsDown() As Boolean
MouseIsDown = GetAsyncKeyState(&H1)
End Function
Sub SimulateButtonClick(shp As shape)
Dim vTopType As Variant, iTopInset As Integer, iTopDepth As Integer, t
With shp.ThreeD
vTopType = .BevelTopType 'Record original button properties
iTopInset = .BevelTopInset
iTopDepth = .BevelTopDepth
.BevelTopType = msoBevelSoftRound
.BevelTopInset = 8
.BevelTopDepth = 8
t = Timer
'#1: use this loop for a temporary "pressed" effect
Do While Timer - t < 0.1
DoEvents
Loop
'OR
'#2: use this loop to wait until mouse button is let up
Do While MouseIsDown
DoEvents
If Timer > (t + 10) Then Exit Do 'in case of glitches...
Loop
.BevelTopType = vTopType
.BevelTopInset = iTopInset
.BevelTopDepth = iTopDepth
DoEvents
End With
End Sub
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.
How do I get the coordinates of the cursor position relative to a rectangle (the one I use to call the macro)?
Here what I got this far:
First: I use the function:
Declare PtrSafe Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
Type POINTAPI
X As Long
Y As Long
End Type
to get the coordinates of the cursor on the screen. Those values are returned by:
Point.X 'pixels to the left of the screen
Point.Y 'pixels to the top of the screen
Second: I created a rectangle like this:
and set the following macro to it:
Sub SH03G13()
Dim Point As POINTAPI: GetCursorPos Point
Dim rectang As Shape: Set rectang = ThisWorkbook.Sheets("Sheet1").Shapes("SH03G13BACK")
Dim ABCISSA As Long: ABCISSA = Point.X - rectang.Left
Dim ORDENAD As Long: ORDENAD = Point.Y - rectang.Top
MsgBox ABCISSA & " " & ORDENAD
End Sub
On my mind, when I did this, I was positive I was getting the coordinates of the cursor inside the green rectangle. However, when I clicked on the black spot on the next image:
the coordinates that my plan returned weren't the expected near 0 coordinates I thought:
Then I realized that the GetCursorPos were returning the position of the cursor relative to the screen while the rectang.Left and rectang.Top commands on my script were returning the position of the rectangle relative to the spreadsheet. So, the lines Point.X - rectang.Left and Point.X - rectang.Left couldn't possibly be right.
Any ideas how I could get the correct coordinates? i.e How can I get the right coordinates near 0 by clicking on the black spot?
Any help will be very appreciated. And, as always, thank you all in advance.
As I told, I got what I want after exploring an idea gived to me by #Luuklag (by aligning the rectangle with a range of cells).
First I put the next code on a different module (just for a well organized code matter):
Option Explicit
Type RECT
Left As Long: Top As Long: Right As Long: Bottom As Long
End Type
Type POINTAPI
X As Long: Y As Long
End Type
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 GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
Function ScreenDPI(bVert As Boolean) As Long
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&)
lDPI(1) = GetDeviceCaps(lDC, 90&)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Function PTtoPX(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window: 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
After this, I set the rectangle with the next macro:
Sub SH03G13()
With ThisWorkbook.Sheets("Sheet1")
Dim AreaRng As Range: Set AreaRng = .Range(.Cells(2, 2), .Cells(13, 10))
Dim rectang As Shape: Set rectang = .Shapes("SH03G13BACK")
rectang.Height = AreaRng.Height
rectang.Width = AreaRng.Width
rectang.Top = AreaRng.Top
rectang.Left = AreaRng.Left
DoEvents
Dim Point As POINTAPI: GetCursorPos Point
Dim rc As RECT: Call GetRangeRect(.Cells(2, 2), rc)
Dim ABCISSA As Long: ABCISSA = Point.X - rc.Left
Dim ORDENAD As Long: ORDENAD = Point.Y - rc.Top
End With
MsgBox "x: " & ABCISSA & ", y: " & ORDENAD
End Sub
The previous macro places and adjusts the rectangle SH03G13BACK to the .Cells(2, 2), .Cells(13, 10) range. Once this is done, the Point.X - rc.Left and Point.Y - rc.Top commands gave me the exact coordinates inside the rectangle (and relative to it), regardless the maximized/minimized state of the excel window, the zoom value, the size/contents of the excel command ribbon or the size/resolution of the screen itself. It's perfect:
I realize this is a little cheating (I know that the GetRangeRect subroutine gives the coordinates relative to the .Cells(2, 2) position. However, for this matter, the trick works like a charm.
Your first problem is Points.X & Points.Y are not relative to the document or the clients individual monitor setup, forget about multi-monitor setups. For example, if the cursor pos = (1000,500) but the application isn't full screen, you have to take into account Application.Left / Application.Top values.
Even so, this isn't a true depiction of where your shape is. rectang.Left / rectang.Top are not relative to the spreadsheet as you mention, they are relative to the spreadsheet object, or window if you will. Meaning, if you were to move the rectangle all the way to the left and top of the spreadsheet it would be (0,0). As show below:
Now, lets say we remove the column headings as well as the formula bar from the ActiveWindow object, the coordinates maintain their position, as shown below:
Clearly they Application environment size has changed, not the rectang.Left position. With that being said, a cursor position of Application.Top + rectang.Top will never be a true representation of where the top of the rectangle is, unless you account for all these run-time circumstances.
Let's say you do take these into account, you do have access to some settings with the ActiveWindow object, like Application.ActiveWindow.DisplayHeadings, and you do make sure you do your best to omit these concerns. You still have a bunch of user preferences to consider, i.e, displayed scrollbars to account for, tabs, the actual ribbon, which may or may not be the same size across clients, minimized or maximized, page layouts, what the current zoom level is alone will cause conflicts, and don't forget about content panes. Let's take, for example, the format shape window pane, moving it to the left of the application and resizing it to an obnoxious width defined by a user:
The coordinates still maintain their relative position, which will not correlate to the cursor position regardless of what properties you have access to, because it will always depend on the user's environment settings.
At this time, my answer would be to say there is no reasonable 'out-of-the-box' method to accomplish this, also for another simple reason that Shape Objects in Excel do not have event handlers for things like onclick or otherwise, in addition to Worksheet.SelectionChange does not fire for selection of Shapes afaik. You could potentially find a "hacky" way by running a loop to continually check for current selection etc, but naturally this is not desired for performance reasons.
As a built in means of accomplishing this, until there are event handlers added for Shape Objects, your best bet might be to port this over to a COM AddIn or populate some kind of VBA Windows Form in the Worksheet where you have more control over client positions, do all your shape manipulation in the form, then add the final product to the spreadsheet when the user is done.
This solution generates the Shape Screen coordinates, following this steps:
Ensures the shape worksheet is active (application.WindowState could be either xlNormal or xlMaximized)
Set the shape object
Sets the shape range screen coordinates
Sets the shape screen coordinates by scanning shape range screen coordinates
This solutions does not need the shape to be aligned to the cells.
Tested successfully for the following situations:
a) Excel window in laptop screen, WindowState =xlNormal
b) Excel window in laptop screen, WindowState =xlMaximized
c) Excel window in alternate screen, WindowState =xlNormal
d) Excel window in alternate screen, WindowState =xlMaximized
These are the procedures:
Option Explicit
Public Type RgCrds
Top As Long
Left As Long
Right As Long
Bottom As Long
End Type
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Public Function Shape_ƒCoordinates_Get(uSpCrds As RgCrds, sp As Shape) As Boolean
Dim wd As Window, rg As Range, oj As Object
Dim uSpOutput As RgCrds, uRgCrds As RgCrds
Dim lX As Long, lY As Long
Dim blX As Boolean, blY As Boolean
Dim b As Byte
On Error GoTo Exit_Err
Rem Set Shape Worksheet Window
sp.TopLeftCell.Worksheet.Activate
Set wd = ActiveWindow
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rem Set Shape Range
Set rg = Range(sp.TopLeftCell, sp.BottomRightCell)
Rem Get Shape Range Coordinates
Call Range_ScreenCoordinates_Get(uRgCrds, rg)
Rem Set Shape Coordinates Limites
With uSpOutput
.Top = uRgCrds.Bottom
.Left = uRgCrds.Right
.Right = uRgCrds.Left
.Bottom = uRgCrds.Top
End With
Rem Scan Shape Range to Get Shape Coordinates - [TopLeft Corner]
blX = False: blY = False
For lX = uRgCrds.Left To uRgCrds.Right
For lY = uRgCrds.Top To uRgCrds.Bottom
Set oj = wd.RangeFromPoint(lX, lY)
If TypeName(oj) <> "Range" Then
If oj.ShapeRange.Type = sp.Type And oj.Name = sp.Name Then
Shape_ƒCoordinates_Get = True
With uSpOutput
If lY < .Top Then .Top = lY Else blX = True
If lX < .Left Then .Left = lX Else blY = True
If blX And blY Then Exit For
End With: End If: End If: Next: Next
Rem Scan Shape Range to Get Shape Coordinates [BottomRight Corner]
blX = False: blY = False
For lX = uRgCrds.Right To uRgCrds.Left Step -1
For lY = uRgCrds.Bottom To uRgCrds.Top Step -1
Set oj = wd.RangeFromPoint(lX, lY)
If TypeName(oj) <> "Range" Then
If oj.ShapeRange.Type = sp.Type And oj.Name = sp.Name Then
Shape_ƒCoordinates_Get = True
With uSpOutput
If lX > .Right Then .Right = lX Else: blX = True
If lY > .Bottom Then .Bottom = lY Else: blY = True
If blX And blY Then Exit For
End With: End If: End If: Next: Next
Rem Coordinates Fine-Tuning
' The RangeFromPoint Method recognizes the Shapes,
' as soon as any part of the cursor is over the shape,
' therefore some fine-tuning is required in order
' to place the entire mouse inside the Shape's body
b = 15 'change as required
With uSpOutput
.Top = .Top + b
.Left = .Left + b
.Right = .Right - b
.Bottom = .Bottom - b
End With
Rem Set Results
uSpCrds = uSpOutput
Shape_ƒCoordinates_Get = True
Exit_Err:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
Public Sub Range_ScreenCoordinates_Get(uOutput As RgCrds, ByVal rg As Range)
Dim wd As Window
With rg
Rem Activate range's worksheet window
.Worksheet.Activate
Application.Goto .Worksheet.Cells(1), 1
Set wd = ActiveWindow
Rem Set Range Screen Coordinates
uOutput.Top = Points_ƒToPixels(.Top * wd.Zoom / 100, 1) + wd.PointsToScreenPixelsY(0)
uOutput.Left = Points_ƒToPixels(.Left * wd.Zoom / 100, 0) + wd.PointsToScreenPixelsX(0)
uOutput.Right = Points_ƒToPixels(.Width * wd.Zoom / 100, 0) + uOutput.Left
uOutput.Bottom = Points_ƒToPixels(.Height * wd.Zoom / 100, 1) + uOutput.Top
End With
End Sub
Private Function Points_ƒToPixels(sgPoints As Single, blVert As Boolean) As Long
Points_ƒToPixels = sgPoints * Screen_ƒDPI(blVert) / 72
End Function
Private Function Screen_ƒDPI(blVert As Boolean) As Long
Static lDPI(0 To 1) As Long, lDC As Long
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&)
lDPI(1) = GetDeviceCaps(lDC, 90&)
lDC = ReleaseDC(0, lDC)
End If
Screen_ƒDPI = lDPI(Abs(blVert))
End Function
Copy the procedures above in a standard module then copy this procedure in a separated module
Option Explicit
Sub Shape_Coordinates_Get_TEST()
Dim ws As Worksheet
Dim sp As Shape
Dim uSpCrds As RgCrds
Rem Set Target Worksheet Active Window
Set ws = ThisWorkbook.Worksheets("SO_Q50293831") 'replace as required
With ws
.Activate
Set sp = .Shapes("SH03G13BACK")
End With
Rem Get Shape Coordinates
If Not (Shape_ƒCoordinates_Get(uSpCrds, sp)) Then Exit Sub 'might want to add a message
Rem Apply Shape Coordinates
With uSpCrds
SetCursorPos .Left, .Top: Stop ' Mouse is now at the Shape's TopLeft corner
SetCursorPos .Left, .Bottom: Stop ' Mouse is now at the Shape's LeftBottom corner
SetCursorPos .Right, .Top: Stop ' Mouse is now at the Shape's RightTop corner
SetCursorPos .Right, .Bottom: Stop ' Mouse is now at the Shape's BottomRigh corner
End With
End Sub
For additional information about the resources used visit these pages:
GetDeviceCaps function
GetDC function
ReleaseDC function
Visual Basic Procedure to Get/Set Cursor Position
NEW EDITED VERSION
Take a look at the following code. The core idea is to use RangeFromPoint, that returns the Shape or Range object that is positioned at the specified pair of screen coordinates.
There logical steps are:
1) get the clicking position and screen dimensions (in pixels).
2) get the first two cells in the visible range that belongs to different row/column, and get their 'excel' position as well as their pixel position.
3) Calculate the relation between 'Excel units' and pixels.
4) scan all shapes in worksheet, take their excel position and calculate their pixel position.
Although a little verbose (not too long, if you delete all lines for writing variables to sheet), I think the code is rather straight, without the need for positioning shapes along cells or checking zoom or similar. You can have many shapes in the sheet, and assign the code to all of them.
The only requirement is that the four cell on the top-left corner of the visible window must not be covered by a shape.
The below code is writing the different variables in the sheet, just for clarity.
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Type POINT
x As Long
y As Long
End Type
Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal index As Long) As Long
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Sub GetPixelsFromImageBorder()
Dim pLocation As POINT
Dim objShape As Object
Dim ScreenWidth As Integer
Dim ScreenHeight As Integer
Dim xPix As Integer, yPix As Integer
Dim Cell_1_X As Double, Cell_1_Y As Double
Dim Cell_2_X As Double, Cell_2_Y As Double
Dim Cell_1_Row As Integer, Cell_1_Col As Integer
Dim Cell_2_Row As Integer, Cell_2_Col As Integer
Dim Cell_1_X_Pix As Double, Cell_1_Y_Pix As Double
Dim Cell_2_X_Pix As Double, Cell_2_Y_Pix As Double
Dim Y0 As Double, X0 As Double
Dim SlopeX As Double, SlopeY As Double
Dim flg1 As Boolean, flg2 As Boolean, flg3 As Boolean
Dim WhichWS As Worksheet
Dim w As Window, r As Range, cll As Range
Dim Shp As Shape
Call GetCursorPos(pLocation)
Set WhichWS = Worksheets("Sheet1")
WhichWS.Range("A1:H20").ClearContents
ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
ClickX = pLocation.x
ClickY = pLocation.y
WhichWS.Cells(3, 1) = "Variable"
WhichWS.Cells(3, 1).Font.Bold = True
WhichWS.Cells(3, 2) = "X"
WhichWS.Cells(3, 2).Font.Bold = True
WhichWS.Cells(3, 3) = "Y"
WhichWS.Cells(3, 3).Font.Bold = True
WhichWS.Cells(4, 1) = "Screen (in pixels): "
WhichWS.Cells(4, 2) = ScreenWidth
WhichWS.Cells(4, 3) = ScreenHeight
WhichWS.Cells(5, 1) = "Mouse clicked on (in pixels): "
WhichWS.Cells(5, 2) = ClickX
WhichWS.Cells(5, 3) = ClickY
Set w = ActiveWindow
Set r = w.VisibleRange
i = 1
For Each cll In r.Cells
If i = 1 Then
'get top and right pos (in excel units) of first cell in visible range
'also get row and column of that cell
Cell_1_Y = cll.Top
Cell_1_X = cll.Left
Cell_1_Row = cll.Row
Cell_1_Col = cll.Column
i = i + 1
ElseIf cll.Row > Cell_1_Row And cll.Column > Cell_1_Col Then
'get top and right pos (in excel units) of second cell in visible range
'also get row and column of that cell
Cell_2_Y = cll.Top
Cell_2_X = cll.Left
Cell_2_Row = cll.Row
Cell_2_Col = cll.Column
Exit For
End If
Next
On Error Resume Next
flg1 = False
flg2 = False
flg3 = False
For yPix = 1 To ScreenHeight
For xPix = 1 To ScreenWidth
Set objShape = ActiveWindow.RangeFromPoint(xPix, yPix)
If Not objShape Is Nothing Then
If TypeName(objShape) = "Range" Then
If objShape.Column = Cell_1_Col And objShape.Row = Cell_1_Row Then
'get top and right pos (in pix) of first cell in visible range
If flg2 = False Then
Cell_1_X_Pix = xPix
Cell_1_Y_Pix = yPix
flg2 = True
End If
ElseIf objShape.Column = Cell_2_Col And objShape.Row = Cell_2_Row Then
'get top and right pos (in pix) of second cell in visible range
If flg3 = False Then
Cell_2_X_Pix = xPix
Cell_2_Y_Pix = yPix
flg3 = True
flg1 = True 'exit of outer loop
Exit For 'exit inner loop (this)
End If
End If
End If
End If
Next
If flg1 = True Then Exit For
Next
'Calculate the relation between pixels and 'excel position'
SlopeY = (Cell_2_Y_Pix - Cell_1_Y_Pix) / (Cell_2_Y - Cell_1_Y)
Y0 = Cell_1_Y_Pix - SlopeY * Cell_1_Y
SlopeX = (Cell_2_X_Pix - Cell_1_X_Pix) / (Cell_2_X - Cell_1_X)
X0 = Cell_1_X_Pix - SlopeX * Cell_1_X
'print some variables in sheet
WhichWS.Cells(6, 1) = "Variable"
WhichWS.Cells(6, 1).Font.Bold = True
WhichWS.Cells(6, 2) = "X Pos (excel units)"
WhichWS.Cells(6, 2).Font.Bold = True
WhichWS.Cells(6, 3) = "Y Pos (excel units)"
WhichWS.Cells(6, 3).Font.Bold = True
WhichWS.Cells(6, 4) = "X Pos (pixels)"
WhichWS.Cells(6, 4).Font.Bold = True
WhichWS.Cells(6, 5) = "Y Pos (pixels)"
WhichWS.Cells(6, 5).Font.Bold = True
WhichWS.Cells(6, 6) = "X Dist. from click (pixels)"
WhichWS.Cells(6, 6).Font.Bold = True
WhichWS.Cells(6, 7) = "Y Dist. from click (pixels)"
WhichWS.Cells(6, 7).Font.Bold = True
i = 7
For Each Shp In WhichWS.Shapes
WhichWS.Cells(i, 1) = Shp.Name
WhichWS.Cells(i, 2) = Shp.Left
WhichWS.Cells(i, 3) = Shp.Top
PosInPixX = X0 + Shp.Left * SlopeX
PosInPixY = Y0 + Shp.Top * SlopeY
DistFromClickX = ClickX - PosInPixX
DistFromClickY = ClickY - PosInPixY
WhichWS.Cells(i, 4) = Round(PosInPixX, 2)
WhichWS.Cells(i, 5) = Round(PosInPixY, 2)
WhichWS.Cells(i, 6) = DistFromClickX
WhichWS.Cells(i, 7) = DistFromClickY
i = i + 1
Next Shp
End Sub
You are nearly there with your code. However Excel App has ribbon that takes some space. In this case, ActiveWindow.PointsToScreenPixelsX(0) and ActiveWindow.PointsToScreenPixelsY(0) will return your worksheet starting pixels relative to the screen.
Now the (mousePos) - (worksheet position) - (left and top of the shapeIn Pixel) will give you mouse position relative to your shape.
Try this code:
Public Function SH03G13()
Dim point As POINTAPI: GetCursorPos point
Dim rectang As Shape: Set rectang = ThisWorkbook.Sheets("Sheet1").Shapes("SH03G13BACK")
Debug.Print "Mouse pointer relative to screen:", point.X, point.Y
Debug.Print "Mouse pointer relative to app:", (point.X - ActiveWindow.PointsToScreenPixelsX(0)), (point.Y - ActiveWindow.PointsToScreenPixelsY(0))
Debug.Print "Mouse pointer relative to shape:", ((point.X - ActiveWindow.PointsToScreenPixelsX(0)) - PointToPixel(rectang.Left)), ((point.Y - ActiveWindow.PointsToScreenPixelsY(0)) - PointToPixel(rectang.Top))
Dim ABCISSA As Long: ABCISSA = point.X - rectang.Left
Dim ORDENAD As Long: ORDENAD = point.Y - rectang.Top
'Debug.Print ABCISSA & " " & ORDENAD
End Function
Public Function PointToPixel(point As Double) As Double
'Converts points to pixel
If point > 0 Then PointToPixel = Round((1.33333333333333 * point), 2) Else PointToPixel = 0
End Function
results in your immediate window will be:
Mouse pointer relative to screen: 410 356
Mouse pointer relative to app: 384 313
Mouse pointer relative to shape: 0 0
Note: You might get -1 coordinates, that's because the on click event fires even if you click slightly away from the shape. You can catch this easily in your function.
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?
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