I searched extensively on this and incredibly there seems to be no answer. Does anyone know how to do this?
The show cursor part is part of PowerPoint - the move part needs to come from an API call. Here you go:
Public Declare Function SetCursorPos Lib "user32.dll" (ByVal X As Long, ByVal Y As Long) As Long
//'USE THIS IF x64: Public Declare PtrSafe Function SetCursorPos Lib "user32.dll" (ByVal X As Long, ByVal Y As Long) As LongPtr
Public Type POINTAPI
X As Long
Y As Long
End Type
Sub ShowCursorAndMove()
Dim currView As SlideShowView
Set currView = ActivePresentation.SlideShowSettings.Run.View
currView.PointerType = ppSlideShowPointerArrow
MoveMouse 400, 300
End Sub
Sub MoveMouse(X As Single, Y As Single)
Dim pt As POINTAPI
pt.X = X
pt.Y = Y
SetCursorPos pt.X, pt.Y
End Sub
Related
Hi I am new to VBA and this seems like a simple problem.
I am trying to get the dimensions of an image in excel and using the GetDeviceCaps function as a result.
I will get a variable not defined compile error regarding the VERTES parameter.
The code I use is the following:
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, _
ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) _
As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As LongPtr _
, ByVal nIndex As Long _
) As LongPtr
Public Sub Test()
Dim tPOS As POINTAPI
Dim AColor As Long
Dim ADC As Long
Dim width As Integer
ADC = GetWindowDC(0)
width = GetDeviceCaps(ADC, VERTRES)
Call GetCursorPos(tPOS)
AColor = GetPixel(ADC, tPOS.x, tPOS.y)
ActiveWindow.Selection.ShapeRange(1).Fill.ForeColor.RGB = 14588691
Debug.Print "width"
Debug.Print width
End Sub
Questions appears to be so basic there isn't anything specific about this online.
i want to select the listitem by hovering the mouse not by clicking.. how to achieve in vba..
i saw a code in a forum using vb.net
Private Sub ListView1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles ListView1.MouseMove
Dim itm As ListViewItem
itm = Me.ListView1.GetItemAt(e.X, e.Y)
If Not itm Is Nothing Then
MessageBox.Show(itm.Text)
End If
itm = Nothing
End Sub
i have this also.. but this doesnt go to other row item.. always selecting the first item.
Private Sub ListView1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
Dim itm As ListItem
Me.ListView1.MultiSelect = False
Set itm = Me.ListView1.HitTest(x, y)
If Not itm Is Nothing Then
itm.Selected = True
End If
End Sub
As I said in my comment, it is a matter of conversion between what Excel unit 'offers' (pixels) and what a list view needs (twips). The working solution will be the next:
Please, copy the next API functions on top of the form code module (in the declarations area):
Option Explicit
Private Declare PtrSafe Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Use the next modified event:
Private Sub ListView1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
Dim itm As MSComctlLib.ListItem
Me.ListView1.SelectedItem.Selected = False ' unselect a previous selected subitem
ConvertPixelsToTwips x, y 'make the necessary units conversion
Set itm = ListView1.HitTest(x, y) 'set the object using the converted coordinates
If Not itm Is Nothing Then
itm.Selected = True
End If
End Sub
Copy the next function, too:
Private Sub ConvertPixelsToTwips(ByRef x As stdole.OLE_XPOS_PIXELS, _
ByRef y As stdole.OLE_YPOS_PIXELS)
Dim hDC As Long, RetVal As Long, TwipsPerPixelX As Long, TwipsPerPixelY As Long
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Const TWIPSPERINCH = 1440
hDC = GetDC(0)
TwipsPerPixelX = TWIPSPERINCH / GetDeviceCaps(hDC, LOGPIXELSX)
TwipsPerPixelY = TWIPSPERINCH / GetDeviceCaps(hDC, LOGPIXELSY)
RetVal = ReleaseDC(0, hDC)
x = x * TwipsPerPixelX: y = y * TwipsPerPixelY
End Sub
I am not the 'father' of the above function. I found the bases on the internet, some years before. I remember that I modified something, but I do not remember what...
Please, try the proposed solution and send some feedback.
I want to get the size of the monitor where the cursor is currently. To do that I took the MonitorFromPoint function to get the monitor from the cursor point.
I have my code down below but it doesn't work properly, it returns 0 when getting the lRight property...
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
lLeft As Long
lTop As Long
lRight As Long
lBottom As Long
End Type
Private Type MONITORINFO
cbSize As Integer
rcMonitor As RECT
rcWork As RECT
dwFlags As Integer
End Type
Private Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (pt As POINTAPI, ByVal dwFlags As LongPtr) As Long
Private Declare PtrSafe Function GetMonitorInfoA Lib "user32.dll" (hMonitor As LongPtr, lpmi As MONITORINFO) As Boolean
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As LongPtr
Private mPoint As POINTAPI
Sub test()
GetCursorPos mPoint ' Get point from cursor current position
Dim hMonitor As LongPtr, MI As MONITORINFO
hMonitor = MonitorFromPoint(mPoint, 2)
MI.cbSize = Len(MI)
GetMonitorInfoA hMonitor, MI
MsgBox MI.rcMonitor.lRight ' returns 0
End Sub
There is a near exact question here
Read pixel colors of an image
The Op actually asks the same question as I'm asking for. But accepts an answer that is nearly there but not quite.. The code below (taken from that thread) does everything I need bar the pixel by pixel bit. If you click on an image it will give you the colour at the click site. As I want to scan the whole picture I though I'd just do an X Y scan and put the sequential X and Y's in instead of the returned X and Y of the GetCursorPos call. But how to get left position and width (for example) in pixels to start the scan? What would I put in my for next loop to address each pixel ?
So to clarify my question.
How to change the code below to scan every pixel of the image not just the clicked cursor position. Thanks
#If VBA7 Then
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As LongPtr
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
#End If
Private Type POINT
x As Long
y As Long
End Type
Sub Picture1_Click()
Dim pLocation As POINT
Dim lColour As Long
Dim lDC As Variant
lDC = GetWindowDC(0)
Call GetCursorPos(pLocation)
lColour = GetPixel(lDC, pLocation.x, pLocation.y)
Range("a1").Interior.Color = lColour
End Sub
Option Explicit
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim IDC As Long
Private Function ScreenDPI(bVert As Boolean) As Long
'*** Get screen DPI ***
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&) 'horz
lDPI(1) = GetDeviceCaps(lDC, 90&) 'vert
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
'*** Swap Points to pixels ****
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Sub GetImageRect(ByRef RC As RECT)
Dim RNG As Range
Set RNG = Sheet1.Range("A1")
'**** using the spread sheet cell A1 as a reference ***
'** find the details of th eimage and convert to pixels ***
Dim wnd As Window
Set wnd = RNG.Parent.Parent.Windows(1)
With Sheet1.Image1
RC.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
RC.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
RC.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + RC.Left
RC.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + RC.Top
End With
End Sub
Sub XYScanOfImage()
'*** put an active X image on sheet1 call it image1 and run this routine **
'** to get the colour information for each pixel *****
Dim RC As RECT
Dim ScanX As Single
Dim ScanY As Single
Dim ImX As Single
Dim ImY As Single
Dim PixCol As Single
Call GetImageRect(RC)
ImX = RC.Left
ImY = RC.Top
IDC = GetDC(0)
'*** scan image left to right top to bottom ****
For ScanX = RC.Left To RC.Right
For ScanY = RC.Top To RC.Bottom
PixCol = GetPixel(IDC, ScanX, ScanY)
'**** PUT CODE IN HERE TO PROCESS THE PIXEL COLOUR ****
Next
Next
IDC = ReleaseDC(0, IDC)
End Sub
The answer from perfo is fantastic - and works!
Some notes to help:
You have to add the image as an ActiveX control (go to the Excel Developer ribbon to to do this, then right-click on the image and set its name to Image1 - this should be the default anyway).
Also, make sure it's on a sheet called Sheet1 in VBA (again, this should be the default).
The routine returns an RGBA colour. I created the following routine to colour each cell:
Sub ColourCell(c As Range, ThisColour As Single)
'colour the passed in range
Dim Red As Byte
Dim Green As Byte
Dim Blue As Byte
Red = ThisColour And &HFF&
Green = (ThisColour And &HFF00&) / 256
Blue = (ThisColour And &HFF0000) / 65535
c.Interior.Color = RGB(Red, Green, Blue)
End Sub
I amended the answer to colour the cells from the active cell down and across as follows:
'*** scan image left to right top to bottom ****
Dim i As Integer
Dim j As Integer
Dim OriginalRowNumber As Integer
Dim OriginalColumnNumber As Integer
OriginalRowNumber = ActiveCell.Row
OriginalColumnNumber = ActiveCell.Column
i = OriginalRowNumber
j = OriginalColumnNumber
Sheet1.Select
Cells.EntireColumn.ColumnWidth = 0.63
Cells.EntireRow.RowHeight = 6
For ScanX = RC.Left To RC.Right
For ScanY = RC.Top To RC.Bottom
PixCol = GetPixel(IDC, ScanX, ScanY)
ColourCell Cells(j, i), PixCol
j = j + 1
Next
i = i + 1
If i Mod 5 = 0 Then Stop
j = OriginalColumnNumber
Next
There are a couple of extra bits in there to set a tiny grid size, so you can see your picture unfolding, and a debug line to pause the macro every 5 columns (it takes a LONG time to run).
I am attempting to have the mouse pointer move at the center of the selected cell when navigating from cell to cell with the Arrow keys
In Excel 2010 the following solution works perfectly
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
SetCursorPos _
ActiveWindow.ActivePane.PointsToScreenPixelsX(Target.Left + (Target.Width / 2)), _
ActiveWindow.ActivePane.PointsToScreenPixelsY(Target.Top + (Target.Height / 2))
End Sub
However in Excel 2003 ActiveWindow.ActivePane does not have the PointsToScreenPixelsX and PointsToScreenPixelsY methods. So I tried to find another solution such as the one below. The X Axis works fine but the Y Axis does not.
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
SetCursorPos _
ActiveWindow.Application.ActiveWindow.PointsToScreenPixelsX((Target.Left + (Target.Width / 2)) / 0.75), _
ActiveWindow.Application.ActiveWindow.PointsToScreenPixelsY((Target.Top + (Target.Height / 2)) / 0.75)
End Sub
I wish this to work regardless of resolution etc. Any ideas?
This should work for older versions of Excel. It's clunky but it gets the job done.
Declare Function SetCursorPos Lib "user32" _
(ByVal x As Long, ByVal y As Long) As Long
Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, ByVal nIndex As Long) As Long
Sub MoveMouseToRange(R As Range)
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&) 'this is the horizontal
'resolution of the user's screen,
'in DPI
lDPI(1) = GetDeviceCaps(lDC, 90&) 'vertical
lDC = ReleaseDC(0, lDC)
End If
Zoom = R.Parent.Parent.Windows(1).Zoom
x = (R.Left + 0.5 * R.Width) * Zoom / 100 / 72 * lDPI(0)
y = (R.Top + 0.5 * R.Height) * Zoom / 100 / 72 * lDPI(1)
SetCursorPos x, y
End Sub