PowerPoint (or Excel) VBA Capture Coordinates of Mouse Click - vba

Some Background:
The quick background is that I am in the research stages of building an add-in for PowerPoint. My end goal is to develop a CAD Dimensioning Add-in to help expedite the creating of Engineering Presentations. We have to do a lot of "PowerPoint Engineering" where the general sizes of components are shown on simplified versions of said components created with PPT shapes or screenshots of the CAD geometry itself. But creating dimensions over and over is tedious. Each one generally consists of an arrow, 2 lines, and a text box with the dimension value.
Here is where I need some help.
(If you know how to do the following in Excel, that would work too and I will work to figure the PPT equivalent later.)
In a PowerPoint slide, while in design mode (i.e. not Slide Show Mode), I want to do the following workflow:
In an open UserForm, the user clicks a button called "START"
The code starts to listen for a left mouse click (LMC) out in the field of the slide itself (It should not respond to a LMC on the actual UserForm, for example if the user needs to drag the UserForm out of the way)
Upon LMC, coordinates of the cursor are recorded as (x1,y1)
Repeat steps 2 & 3 to record (x2, y2)
Do stuff with these coordinates (e.g. draw a dimension between the two coordinates
I believe I can handle all of the coding with the exception step 2, which is why I am here. I am having much trouble finding a starting point. Specifically, I need help with how to listen for a LMC. In words, what envision is the following:
While Listening:
If LMC = TRUE
Do Stuff
End If
End While
But I don't have the knowledge to code the While Listening part. I need a nudge in the right direction.
My searches have landed me on the MouseDown event handler pages at MSDN, but in my testing, I don't think that this is what I need. Its seem as though MouseDown is intended to start a routine when the Mouse is Down on a CommandButton in the UserForm it self.
I have also found this SO post where the only answer seemed to imply that this was not possible without going to great lengths AND the code was possible detrimental to the file itself: How to record mouse clicks in Excel VBA?. (I have no problem going to great lengths and putting in the work, but not if the resulting code has a high likelihood of doing damage as the post seems to suggest.) (Also, the OP was downvoted with no explanation, maybe someone can tell me why so I don't make the same mistake.)

You can accomplish what you are looking to do by doing the following (the bottom part may be the most helpful to you):
First, Declare the following:
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
and the following code snippets will allow you do either click, double click, or right click:
Private Sub SingleClick()
SetCursorPos 100, 100 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Private Sub DoubleClick()
'Double click as a quick series of two clicks
SetCursorPos 100, 100 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Private Sub RightClick()
Right Click
SetCursorPos 200, 200 'x and y position
mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
End Sub
All you need to do is change the cursor position to the coordinates on the screen.
To do this, I made a new macro with the following code and assigned it to the "Ctrl+Y" button. This will tell you the coordinates of your current mouse location.
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
x As Long
y As Long
End Type
Sub CurosrXY_Pixels()
Dim lngStatus As Long
Dim typWhere As POINTAPI
lngStatus = GetCursorPos(typWhere)
MsgBox "x: " & typWhere.x & Chr(13) & "y: " & typWhere.y, vbInformation, "Pixels"
End Sub

Related

Mouse event wheel occurs last

something strange is happening in my application and I can't figure out what it is. I am trying to simulate Mouse click and scroll programmatically.
I can successfully perform Mouse click and scroll programmatically, but the problem is that the mouse wheel occurs last.
This is the code:
<DllImport("user32.dll", EntryPoint:="mouse_event")>
Private Shared Sub mouse_event(ByVal dwFlags As UInteger, ByVal dx As
Integer, ByVal dy As Integer, ByVal dwData As Integer, ByVal dwExtraInfo
As UInteger)
End Sub
Flags:
Const MOUSEEVENTF_LEFTDOWN As UInteger = &H2 '0x0002'
Const MOUSEEVENTF_LEFTUP As UInteger = &H4 '0x0004'
Const MOUSEEVENTF_WHEEL As UInteger = &H800
Const MOUSEEVENTF_XDOWN As UInteger = &H80
Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
scroll_to_end()
Thread.Sleep(300)
click_perf()
MessageBox.Show("S")
End Sub
Private Sub scroll_to_end()
'Focus panel1'
c_point = New Point(Panel1.Location.X + 1, Panel1.Location.Y + 1)
Cursor.Position = Me.PointToScreen(c_point)
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
'Wait'
Thread.Sleep(150)
'Scroll to the end of the page'
Dim scroll_down As Integer = -(10 * 120) 'Perform 10 scrolls down'
mouse_event(MOUSEEVENTF_WHEEL, 0, 0, scroll_down, 0)
'This is the fix:'
Application.DoEvents()
End Sub
Private Sub click_perf()
'Move mouse diagonally 200px'
c_point.X += 200
c_point.Y += 200
Cursor.Position = Me.PointToScreen(c_point)
'Perform click'
mouse_event(MOUSEEVENTF_LEFTDOWN, c_point.X, c_point.Y, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
End Sub
When I click button3, I want to focus panel1 then scroll to the end and move mouse 200px diagonally downwards and then simulate click.
What actually happens: Mouse moves to panel1, simulates mouse button down and mouse button up. Then, it moves the mouse diagonally 200px and the messagebox shows up. The scroll didn't even occur and now when I close the messagebox panel1 probably loses the focus and doesn't scroll.
If I remove messagebox.show(""): Mouse moves to panel1 and focuses it just like above. It scrolls to the end, but it performs click before it was scrolled down.
EDIT:
To fix this issue we need to put Application.DoEvents() After WHEEL MOUSE EVENT.
Put this after each UI operation to force it to happen in order
Application.DoEvents()
UI events are handled in a message loop, which looks at a queue of messages and handles them. There is no guarantee that they will be handled in the order they are raised if they are raised around the same time in your code because your code is faster than the loop. Application.DoEvents() will halt your code execution and force the loop to handle all pending messages, thus making them happen in order.
It's generally considered poor practice to use this method, however, on account of its widespread misuse. I think your case for it is a good one and maybe the only I've ever seen.
I'd be interested to see if someone can provide a preferred alternative...

Global hotkey not registered in game using GetAsyncKeyState - vb.net

I've made a tool that will continuously click for the user if they decide to have it on with toggle keys etc, it all works fine in ordinary windows e.g google chrome, but when it comes to games it doesn't always work correctly.
(well it does in some games, then others it doesn't)
The code is designed to click fast while holding LButton, then stop when it's let go to act as an autoclicker (user has control of speed) which again works, but when in a game it clicks alot slower than it's suppose to / any other window / app.
I've figured out adding a delay using
Thread.Sleep(200)
fixes the speed of the autoclicker in game, but then it messes up the keybind which results in the autoclicker always clicking even when LButton isnt held / pressed.
Is there anything else that I could use as a delay, or anything else I can do to the code so it works correctly?
I've been trying many different variations and searching online the last few days trying to get it working, but none succeeded.
Here's all the code got to do with autoclicking in my project, i've added some notes to try and explain which part is doing what / speeds the timers are set to.
Imports System.Threading
Public Class Form1
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Integer) As Short
Private Declare Sub mouse_event Lib "user32" (ByVal dwflags As Integer, ByVal dx As Integer, ByVal cbuttons As Integer, ByVal dy As Integer, ByVal dwExtraInfo As Integer)
Private Const mouseclickup = 4
Private Const mouseclickdown = 2
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'Timer1 isnt doing the clicking, Timer1 is just listening for LButton
'clicks which is why I have it always on aswell as a low interval.
Timer1.Start()
Timer1.Interval = 1
'LButton is the timer that will do the clicking.
LButton.Interval = 100
End Sub
Private Sub LButton_Tick(sender As Object, e As EventArgs) Handles LButton.Tick
If GetAsyncKeyState(Keys.LButton) Then
mouse_event(mouseclickup, 0, 0, 0, 0)
'Without Thread.Sleep(200) the code works as it's suppose to, clicks
'when LButton is held, stops clicking when LButton is let go,
'although without Thread.Sleep(200) it will not work in all games,
'but with it, it will continuously click even when LButton isn't held.
Thread.Sleep(200)
mouse_event(mouseclickdown, 0, 0, 0, 0)
Else
LButton.Stop()
End If
End Sub
Private Sub Timer1_Tick_1(sender As Object, e As EventArgs) Handles Timer1.Tick
'This is what will listen for the left clicks and also stop the left
'LButton timer if LButton is not held
If GetAsyncKeyState(Keys.LButton) Then
LButton.Start()
Else
LButton.Stop()
End If
End Sub
End Class
Quoting the MSDN documentation, GetAsyncKeyState() determines:
whether a key is up or down at the time the function is called, and whether the key was pressed after a previous call to GetAsyncKeyState.
So when you check the function via If GetAsyncKeyState(Keys.LButton) Then, it will return non-zero at least three times, thus execute the code more than you want (which is what you experience when you add Thread.Sleep(200)).
To check if the key is held down you have to check if the most significant bit is set, which for a Short is 0x8000 in hex and 32768 in decimal.
Checking a bit flag is done by checking (<number> And <bit>) = <bit> - where And is the bitwise And operator.
This would result in your code looking like this:
Const KeyDownBit As Integer = &H8000
Private Sub LButton_Tick(sender As Object, e As EventArgs) Handles LButton.Tick
If (GetAsyncKeyState(Keys.LButton) And KeyDownBit) = KeyDownBit Then
mouse_event(mouseclickup, 0, 0, 0, 0)
Thread.Sleep(200)
mouse_event(mouseclickdown, 0, 0, 0, 0)
Else
LButton.Stop()
End If
End Sub
Private Sub Timer1_Tick_1(sender As Object, e As EventArgs) Handles Timer1.Tick
If (GetAsyncKeyState(Keys.LButton) And KeyDownBit) = KeyDownBit Then
LButton.Start()
Else
LButton.Stop()
End If
End Sub
I'm not sure whether your second timer (Timer1) is actually needed in this case.

How to prevent the Console window being resized in VB.NET?

I need to prevent the user of my console program from resizing the window, only allowing it to be changed programmatically. If the user changes the width, everything messes up. Also, I want to disable the maximise button. Are either of these possible in Console?
This answer neatly covers how to disable resizing a form in WinForms, but it won't work for Console.
I came up with a solution that prevents re-sizing of a console window application (either by dragging the corner border or by clicking on the maximize or minimize buttons). The following code is written in the form of a complete VB.Net console application (i.e., a Module):
Module Module1
Private Const MF_BYCOMMAND As Integer = &H0
Public Const SC_CLOSE As Integer = &HF060
Public Const SC_MINIMIZE As Integer = &HF020
Public Const SC_MAXIMIZE As Integer = &HF030
Public Const SC_SIZE As Integer = &HF000
Friend Declare Function DeleteMenu Lib "user32.dll" (ByVal hMenu As IntPtr, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Friend Declare Function GetSystemMenu Lib "user32.dll" (hWnd As IntPtr, bRevert As Boolean) As IntPtr
Sub Main()
Dim handle As IntPtr
handle = Process.GetCurrentProcess.MainWindowHandle ' Get the handle to the console window
Dim sysMenu As IntPtr
sysMenu = GetSystemMenu(handle, False) ' Get the handle to the system menu of the console window
If handle <> IntPtr.Zero Then
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND) ' To prevent user from closing console window
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND) 'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND) 'To prevent the use from re-sizing console window
End If
Do Until (Console.ReadKey.Key = ConsoleKey.Escape)
'This loop keeps the console window open until you press escape
Loop
End Sub
End Module
I based this answer off of the Stack Overflow question/answer: "Disable the maximize and minimize buttons of a c# console [closed]"
Please let me know if this doesn't work for you. Good luck!
I wanted to comment on the accepted answer, but I lack reputation...
To prevent the console window from resizing when you snap it to a corner, you can use
Console.SetBufferSize(80, 24) ' or whatever size you're using...

Visual Basic, what is the send key for this button?

here is a link to the button im referring to
http://blog.laptopmag.com/wpress/wp-content/uploads/2012/07/ThinkPad-Keyboard-Face-Off_g4-T420.jpg
and the format im trying to find it coincides with this sort of formatting
{PGUP} = page up button
{LEFT} = left arrow
{ESC} = Escape
anybody know how you can send this as a sendkey? prefer to use this keyboard orientated method than sending right click to a screen as that causes its own issues with finding location through an emulator screen.
cheers to anyone who can help me, even if someone knows for certain it doesn't exist it means i can focus on something else instead :)
EDIT:
TL;DR
"+{F10} might be what you are looking for to bring up what is called the 'context menu' however if you are using a citrix (or similar) application then you might have issues with stuff not being in focus." :)
So what I have discovered on my own. there are several ways to send what I now know is the 'context menu' key. only one however was applicable to my situation.
if I was able to write the code for sendkey then drarig29's answer might have worked but with the application I'm using (BluePrism I can not do it that way unfortunately) this was my solution (that doesn't work)
"+{F10}"
so '+' = SHIFT and F10 = F10 button. So shift F10 will work for people who are looking for a way to bring up the 'right-click menu' however this will not work for me, though im not sure why. I'm automating an application through citrix (emulator screen) and even though I make the mouse click on the screen and the use the sendKey "+{F10}" it does not make the context menu screen appear on the application. So I tried it manually and funny enough it also doesn't work in bringing up the context menu. Then I found out if you right click the area of the screen and the menu comes up then the send key works all of a sudden with no hitch. I think the problem is to do with some windows being in focus and some not but I have to work it out to be sure seeing as i sent a 'click' to the right area of the screen it should be in focus. but anyways cheers for the help :)
This is the context menu key. Its keycode is 93. To send a key using its keycode, use this :
<DllImport("user32.dll")> _
Private Shared Function keybd_event(bVk As Byte, bScan As Byte, dwFlags As UInteger, dwExtraInfo As Integer) As Boolean
End Function
Const KEYEVENTF_KEYDOWN = &H0
Const KEYEVENTF_KEYUP = &H2
Private Sub SendKey(KeyCode As Integer)
keybd_event(CByte(KeyCode), 0, KEYEVENTF_KEYDOWN, 0)
keybd_event(CByte(KeyCode), 0, KEYEVENTF_KEYUP, 0)
End Sub
You have to import System.Runtime.InteropServices (Imports System.Runtime.InteropServices).
With this, to send context menu key, use SendKey(93).
Edit :
Declare Sub mouse_event Lib "user32" Alias "mouse_event" (ByVal dwFlags As Integer, ByVal dx As Integer, ByVal dy As Integer, ByVal cButtons As Integer, ByVal dwExtraInfo As Integer)
Const MOUSEEVENTF_LEFTDOWN As Int32 = &H2
Const MOUSEEVENTF_LEFTUP As Int32 = &H4
Const MOUSEEVENTF_RIGHTDOWN As Int32 = &H8
Const MOUSEEVENTF_RIGHTUP As Int32 = &H10
Enum ClickType
Left = 0
Right = 1
End Enum
Sub SendClick(ClickType As ClickType, DestX As Integer, DestY As Integer)
Select Case ClickType
Case ClickType.Left
Cursor.Position = New Point(DestX, DestY)
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
Case ClickType.Right
Cursor.Position = New Point(DestX, DestY)
mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0)
End Select
End Sub
Use the previous method like that : SendClick(ClickType.Left, 20, 20)

Outlook VBA Macro: Best way to indicate 'please wait'

What's the best practice for indicating to the user that a Macro is running within Outlook ?
The macro can take around 1-30 seconds to complete.
I want to avoid a modal 'msgbox' popping up before the macro is run, as this can be annoying.
I would rather avoid the hourglass cursor if possible, and wondered if there was a better way.
Is there a way of placing a non-modal 'status' message up, whilst the macro is running?
(The macro I have runs against the currently selected mailItem - and it launched by a button on the Quick Access Toolbar).
This article (also this) on best practice says use the status bar.
This article on Outlook says:
Changing the Status Bar
There is no
way to change the status bar text in
Microsoft Outlook. The status bar is
not exposed as it is in other
Microsoft Office object models.
Outlook.com provides code for a progress box.
Couple of things that string to mind, I am sure other will have ideas as well.
1.Show a form with a progress bar on it that reports progress or has the progress bar in marque mode if you can’t report progress
2.Show a form with a picture box with your favourite animated gif inside(spinny pizza etc.). You can turn off the buttons etc.
3. Use win api to get play with the outlook staus bar
Not knowing what you are doing in your macro you may have to deal with keeping the form “On top” and pumping async progress into it.
Cheers
Marcus
Expanding on #76mel's answer, a nice way to do this is with a non-modal userform. Make something really simple with just a label and caption like this:
What I like to do is have the userform set as:
Non modal (in properties F4, set ShowModal to false)
This means you can click outside the status bar and it doesn't stop you.
I set the StartupPosition to 0-Manual and Top and Left to something like 100 so that the Status form appears in the top left corner of the screen (out of the way of any other messages which appear in centre by default)
Set the label's value to some default text for when the Userform first loads
Public strStatus As String
Public Const defaultStatus As String = "Default status text" 'set this to whatever you want
Sub statusReporter()
frmStatus.Show
'''
'Your code here
'''
frmStatus.lblStatus = "Step 1"
'...
frmStatus.lblStatus = "Step 2"
'...
'''
'Unload the form
'''
frmStatus.lblStatus = defaultStatus
frmStatus.Hide
End Sub
Note, like with Excel's Application.Statusbar you must reset the userform to its default value if you plan to use it later on in the same instance of Excel
Optionally use this too
'Written By RobDog888 - VB/Office Guru™
'Add a Command Button so you can toggle the userform's topmost effect
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private mlHwnd As Long
Private Sub UserForm_Initialize()
Dim overTim As Single
overTim = Timer
mlHwnd = FindWindow("ThunderDFrame", "Status") 'Change "Status" to match your userforms caption
Do While mlHwnd = 0 And Timer - overTim < 5
mlHwnd = FindWindow("ThunderDFrame", "Status")
DoEvents
Loop
'Set topmost
SetWindowPos mlHwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub
in the userform code itself to keep it on top always