I'm trying to use a web-style button on my form, using some pictures(ok-off button, ok-pressed button and ok button)
I'm tryin to do the same as in a website. change button color when rolling over the mouse and change color again when click.
But I'm missing something here. I have achieved to change the button imagen when mouse is over it, but when i click on it, only change the picture(by procedure MouseMove), but when I release mouse button, event can't go to mouseUp event. WHat am I missing?
Private Sub okpress_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If okpress.Visible = True Then
okoff.Visible = False
okpress.Visible = True
ok.Visible = False
End If
MsgBox "ha entrado", vbOKOnly, "Prueba"
End Sub
Private Sub okoff_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If okoff.Visible = True Or okpress.Visible = True Then
okoff.Visible = False
okpress.Visible = False
ok.Visible = True
End If
End Sub
Private Sub ok_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If okpress.Visible = False Then
okoff.Visible = False
okpress.Visible = True
ok.Visible = False
End If
Dim a As Integer, b As Index, c As Single, d As Single
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ok.Visible = False
okpress.Visible = False
okoff.Visible = True
End Sub
The MouseUP event occurs after a MouseDOWN on the same form, and not where the mouse is. And when you hide the form, you also stop the event chain.
A solution for your case would be, instead of hiding the button, just show the other one in front of it.. So the MouseUP event will still occur when you release the mouse, and the result will be the same.
--
Place the buttons/images from back to front in this order: ok(c1), off(c2), press(c3)
Code:
Private Sub c1_Click()
c1.Visible = False
c2.Visible = True
End Sub
Private Sub c1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
c3.Visible = True
End Sub
Private Sub c1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
c3.Visible = False
End Sub
Private Sub c2_Click()
c1.Visible = True
c2.Visible = False
End Sub
Private Sub c2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
c3.Visible = True
End Sub
Private Sub c2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
c3.Visible = False
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
c1.Visible = False
c3.Visible = False
c2.Visible = True
End Sub
Related
I'm programming in Visual Basic 6.0 at the moment, just for fun.
I've come across an annoying issue that if I try and scale my pictures at all at runtime then it blurs and I can't read the text on the picture. If I scale it at design time then it scales just fine.
The picture is in 24-bit Bitmap file type, the same results come with using .gif or .jpeg also. VB6 doesn't handle PNG's as far as I'm aware. PictureBox's don't anyway.
Code for drawing at runtime: (correct aspect ratio)
Picture1.PaintPicture map, 0, 0, 700, 547
Can anyone tell me why this is happening or if I'm doing it wrong?
I realise VB6 is out-dated and not supported, but as I say I am using it for a fun project.
Design time quality:
Run time quality:
Run time quality in VS2017 (C#):
Here is a UserControl implementation that you can use instead of a PictureBox control that uses StretchBlt for better quality:
VERSION 5.00
Begin VB.UserControl ImageBox
ClientHeight = 648
ClientLeft = 0
ClientTop = 0
ClientWidth = 720
ClipControls = 0 'False
ForwardFocus = -1 'True
ScaleHeight = 54
ScaleMode = 3 'Pixel
ScaleWidth = 60
Begin VB.PictureBox picBuffer
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 372
Left = 120
ScaleHeight = 31
ScaleMode = 3 'Pixel
ScaleWidth = 36
TabIndex = 0
Top = 120
Visible = 0 'False
Width = 432
End
End
Attribute VB_Name = "ImageBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'###############################################################################
'#
'# ImageBox
'#
'###############################################################################
Option Explicit
'###############################################################################
'### Constants #################################################################
'###############################################################################
Private Const STRETCH_ANDSCANS = 1
Private Const STRETCH_DELETESCANS = 3
Private Const STRETCH_HALFTONE = 4
Private Const STRETCH_ORSCANS = 2
Private Const SRCCOPY = &HCC0020
'###############################################################################
'### APIs ######################################################################
'###############################################################################
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) _
As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, _
ByVal nStretchMode As Long) _
As Long
'###############################################################################
'### Data ######################################################################
'###############################################################################
'###############################################################################
'### Events ####################################################################
'###############################################################################
Event Click()
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
'###############################################################################
'### Public Methods ############################################################
'###############################################################################
'*******************************************************************************
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
UserControl.BackColor() = New_BackColor
PropertyChanged "BackColor"
End Property
'*******************************************************************************
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled() = New_Enabled
PropertyChanged "Enabled"
End Property
'*******************************************************************************
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
BorderStyle = UserControl.BorderStyle
End Property
Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
UserControl.BorderStyle() = New_BorderStyle
PropertyChanged "BorderStyle"
End Property
'*******************************************************************************
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
Call UserControl.Refresh
End Sub
'*******************************************************************************
Public Property Get Picture() As Picture
Set Picture = picBuffer.Picture
End Property
Public Property Set Picture(ByVal New_Picture As Picture)
Set picBuffer.Picture = New_Picture
PropertyChanged "Picture"
Me.Refresh
End Property
'###############################################################################
'### GUI Events ################################################################
'###############################################################################
'*******************************************************************************
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
'*******************************************************************************
Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub
'*******************************************************************************
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseDown(Button, Shift, x, y)
End Sub
'*******************************************************************************
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseMove(Button, Shift, x, y)
End Sub
'*******************************************************************************
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseUp(Button, Shift, x, y)
End Sub
'*******************************************************************************
Private Sub UserControl_Paint()
Dim lSave As Long
'set the stretchblit mode (saving the previous value)
lSave = SetStretchBltMode(UserControl.hdc, STRETCH_HALFTONE)
'perform blit
Call StretchBlt(UserControl.hdc, 0, 0, UserControl.ScaleWidth, _
UserControl.ScaleHeight, picBuffer.hdc, 0, 0, _
picBuffer.ScaleWidth, picBuffer.ScaleHeight, SRCCOPY)
'restore previous mode
Call SetStretchBltMode(UserControl.hdc, lSave)
End Sub
'###############################################################################
'### UserControl Events ########################################################
'###############################################################################
'*******************************************************************************
' Initialize Properties for User Control
'*******************************************************************************
Private Sub UserControl_InitProperties()
'Set any defaults that should be saved from design-time to run-time here
UserControl.Enabled = True
End Sub
'*******************************************************************************
' Load property values from storage
'*******************************************************************************
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'Set any values that were saved from design-time to run-time
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
UserControl.BackStyle = PropBag.ReadProperty("BackStyle", 1)
UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
Set Picture = PropBag.ReadProperty("Picture", Nothing)
End Sub
'*******************************************************************************
' Write property values to storage
'*******************************************************************************
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'Store any values that should be saved from design-time to run-time here
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
Call PropBag.WriteProperty("BackStyle", UserControl.BackStyle, 1)
Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
Call PropBag.WriteProperty("Picture", Picture, Nothing)
End Sub
'*******************************************************************************
' Terminate fires when the form unloads.
'*******************************************************************************
Private Sub UserControl_Terminate()
'
End Sub
'###############################################################################
'### Private Methods ###########################################################
'###############################################################################
'###############################################################################
'###############################################################################
'###############################################################################
I need to open an external window from an external exe (eg Notepad) and move & size it to a predefined size & position.
I am trying to use MoveWindow API but is seems it is not working. I am using Windows 8 x64 and VS2012.
Here is my code:
<DllImport("user32.dll")> _
Public Function MoveWindow(ByVal hWnd As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Boolean) As Boolean
End Function
Public Sub NoveNotepad()
Dim ApplicationProcess = System.Diagnostics.Process.Start("Notepad.exe")
ApplicationProcess.WaitForInputIdle()
Dim ApplicationHandle = ApplicationProcess.MainWindowHandle
Dim z = MoveWindow(ApplicationHandle, 600, 600, 600, 600, True) ' THIS RETURNS TRUE
End Sub
You could try using SetWindowPos() instead? Not sure why MoveWindow() wouldn't work...
Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" _
(ByVal hwnd As IntPtr, ByVal hWndInsertAfter As Integer, _
ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, _
ByVal wFlags As Integer) As Integer
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim ApplicationProcess = System.Diagnostics.Process.Start("Notepad.exe")
ApplicationProcess.WaitForInputIdle()
Dim ApplicationHandle = ApplicationProcess.MainWindowHandle
SetWindowPos(ApplicationHandle, 0, 600, 600, 600, 600, 0)
End Sub
I'm working with a Dell Latitude ST2 tablet. It's running Windows 8 Pro on an Intel Atom processor.
I'm trying to do a simultaneous image capture from both the front and rear facing cameras. I'm messing around with the code from here: http://www.codeproject.com/Articles/18511/Webcam-using-DirectShow-NET
I can only get the rear facing camera, and even then the image capture doesn't work. The stream is just fine. (Less concerned about this than I am the dual streams.)
The two image sensors in the tablet are OV8830 and OV2720.
Also, is there a better API or method rather than using DirectShow for what I'm trying to accomplish?
Thanks!
Edit: I forgot to mention I'm working in VB. I'd prefer to stick with an Windows Forms Application.
I have tried this method just a day back with small modifications in the code.For me the image stream as well as the capture is working great.i will place my code here.you can have your modification for application to work for you.
Imports System.Runtime.InteropServices
Imports System.IO
Public Class FrmCam
Const WM_CAP As Short = &H400S
Const WM_CAP_DRIVER_CONNECT As Integer = WM_CAP + 10
Const WM_CAP_DRIVER_DISCONNECT As Integer = WM_CAP + 11
Const WM_CAP_EDIT_COPY As Integer = WM_CAP + 30
Public Const WM_CAP_GET_STATUS As Integer = WM_CAP + 54
Public Const WM_CAP_DLG_VIDEOFORMAT As Integer = WM_CAP + 41
Const WM_CAP_SET_PREVIEW As Integer = WM_CAP + 50
Const WM_CAP_SET_PREVIEWRATE As Integer = WM_CAP + 52
Const WM_CAP_SET_SCALE As Integer = WM_CAP + 53
Const WS_CHILD As Integer = &H40000000
Const WS_VISIBLE As Integer = &H10000000
Const SWP_NOMOVE As Short = &H2S
Const SWP_NOSIZE As Short = 1
Const SWP_NOZORDER As Short = &H4S
Const HWND_BOTTOM As Short = 1
Private DeviceID As Integer = 0 ' Current device ID
Private hHwnd As Integer ' Handle to preview window
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
ByRef lParam As CAPSTATUS) As Boolean
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Boolean, _
ByRef lParam As Integer) As Boolean
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
ByRef lParam As Integer) As Boolean
Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Integer, _
ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, _
ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer
Declare Function DestroyWindow Lib "user32" (ByVal hndw As Integer) As Boolean
Structure POINTAPI
Dim x As Integer
Dim y As Integer
End Structure
Public Structure CAPSTATUS
Dim uiImageWidth As Integer '// Width of the image
Dim uiImageHeight As Integer '// Height of the image
Dim fLiveWindow As Integer '// Now Previewing video?
Dim fOverlayWindow As Integer '// Now Overlaying video?
Dim fScale As Integer '// Scale image to client?
Dim ptScroll As POINTAPI '// Scroll position
Dim fUsingDefaultPalette As Integer '// Using default driver palette?
Dim fAudioHardware As Integer '// Audio hardware present?
Dim fCapFileExists As Integer '// Does capture file exist?
Dim dwCurrentVideoFrame As Integer '// # of video frames cap'td
Dim dwCurrentVideoFramesDropped As Integer '// # of video frames dropped
Dim dwCurrentWaveSamples As Integer '// # of wave samples cap'td
Dim dwCurrentTimeElapsedMS As Integer '// Elapsed capture duration
Dim hPalCurrent As Integer '// Current palette in use
Dim fCapturingNow As Integer '// Capture in progress?
Dim dwReturn As Integer '// Error value after any operation
Dim wNumVideoAllocated As Integer '// Actual number of video buffers
Dim wNumAudioAllocated As Integer '// Actual number of audio buffers
End Structure
Declare Function capCreateCaptureWindowA Lib "avicap32.dll" _
(ByVal lpszWindowName As String, ByVal dwStyle As Integer, _
ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Short, ByVal hWndParent As Integer, _
ByVal nID As Integer) As Integer
Declare Function capGetDriverDescriptionA Lib "avicap32.dll" (ByVal wDriver As Short, _
ByVal lpszName As String, ByVal cbName As Integer, ByVal lpszVer As String, _
ByVal cbVer As Integer) As Boolean
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
LoadDeviceList()
If Not Directory.Exists(Application.StartupPath & "\Images") Then
Directory.CreateDirectory(Application.StartupPath & "\Images")
End If
If lstDevices.Items.Count > 0 Then
btnStart.Enabled = True
lstDevices.SelectedIndex = 0
btnStart.Enabled = True
Else
lstDevices.Items.Add("No Capture Device")
btnStart.Enabled = False
End If
Me.AutoScrollMinSize = New Size(100, 100)
btnStop.Enabled = False
btnSave.Enabled = False
'picCapture.SizeMode = PictureBoxSizeMode.StretchImage
End Sub
Private Sub LoadDeviceList()
Dim strName As String = Space(100)
Dim strVer As String = Space(100)
Dim bReturn As Boolean
Dim x As Short = 0
'
' Load name of all avialable devices into the lstDevices
'
Do
'
' Get Driver name and version
'
bReturn = capGetDriverDescriptionA(x, strName, 100, strVer, 100)
'
' If there was a device add device name to the list
'
If bReturn Then lstDevices.Items.Add(strName.Trim)
x += CType(1, Short)
Loop Until bReturn = False
End Sub
Private Sub OpenPreviewWindow()
Dim iHeight As Integer = Piccapture.Height
Dim iWidth As Integer = Piccapture.Width
'
' Open Preview window in picturebox
'
hHwnd = capCreateCaptureWindowA(DeviceID.ToString, WS_VISIBLE Or WS_CHILD, 0, 0, 1280, _
1024, Piccapture.Handle.ToInt32, 0)
'
' Connect to device
'
If SendMessage(hHwnd, WM_CAP_DRIVER_CONNECT, DeviceID, 0) Then
'
'Set the preview scale
'
SendMessage(hHwnd, WM_CAP_SET_SCALE, True, 0)
'
'Set the preview rate in milliseconds
'
SendMessage(hHwnd, WM_CAP_SET_PREVIEWRATE, 66, 0)
'
'Start previewing the image from the camera
'
SendMessage(hHwnd, WM_CAP_SET_PREVIEW, True, 0)
'
' Resize window to fit in picturebox
'
SetWindowPos(hHwnd, HWND_BOTTOM, 0, 0, Piccapture.Width, Piccapture.Height, _
SWP_NOMOVE Or SWP_NOZORDER)
btnSave.Enabled = True
btnStop.Enabled = True
btnStart.Enabled = False
Else
'
MsgBox("No Device Connected", MsgBoxStyle.Information, "RStar")
'
DestroyWindow(hHwnd)
btnSave.Enabled = False
End If
End Sub
Private Sub btnStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStart.Click
DeviceID = lstDevices.SelectedIndex
'If DeviceID = 0 Then
' MsgBox("No Device Found", MsgBoxStyle.Information, "RStar")
' Exit Sub
'End If
OpenPreviewWindow()
Dim bReturn As Boolean
Dim s As CAPSTATUS
bReturn = SendMessage(hHwnd, WM_CAP_GET_STATUS, Marshal.SizeOf(s), s)
Debug.WriteLine(String.Format("Video Size {0} x {1}", s.uiImageWidth, s.uiImageHeight))
End Sub
Private Sub ClosePreviewWindow()
'
' Disconnect from device
'
SendMessage(hHwnd, WM_CAP_DRIVER_DISCONNECT, DeviceID, 0)
'
' close window
'
DestroyWindow(hHwnd)
End Sub
Private Sub btnStop_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStop.Click
ClosePreviewWindow()
btnSave.Enabled = False
btnStart.Enabled = True
btnStop.Enabled = False
End Sub
Private Sub btnSave_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnSave.Click
Dim data As IDataObject
Dim bmap As Bitmap
Dim filepath As String
'
' Copy image to clipboard
'
SendMessage(hHwnd, WM_CAP_EDIT_COPY, 0, 0)
'
' Get image from clipboard and convert it to a bitmap
'
data = Clipboard.GetDataObject()
If data.GetDataPresent(GetType(System.Drawing.Bitmap)) Then
bmap = CType(data.GetData(GetType(System.Drawing.Bitmap)), Bitmap)
Piccapture.Image = bmap
ClosePreviewWindow()
btnSave.Enabled = False
btnStop.Enabled = False
btnStart.Enabled = True
Trace.Assert(Not (bmap Is Nothing))
filepath = Application.StartupPath & "\Images\" & frmChartOfAccounts.txtAcName.Text & frmChartOfAccounts.txtRegNo.Text & ".jpeg"
bmap.Save(filepath)
frmChartOfAccounts.txtimg.Text = filepath
End If
End Sub
Private Sub Form1_Closing(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing
If btnStop.Enabled Then
ClosePreviewWindow()
End If
End Sub
Private Sub btnInfo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
'SendMessage(hHwnd, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub
Private Sub cmdExit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdExit.Click
Close()
End Sub
End Class
Hope it will help you.
Is it possible in visual basic to have a button that you can move with a mouse drag, which stays on the same horizontal line and only moves a certain distance each way. Something like the balance control on the sound for a computer
Here's a simple example to drag a button named Command1. To limit the distance it can move, just add some conditions to the DragOver event:
Dim blnDrag As Boolean
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not blnDrag Then
blnDrag = True
Command1.Drag
End If
End Sub
Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.DragMode = vbnone
blnDrag = False
End Sub
Private Sub Form_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
Command1.Left = X
End Sub
Private Sub Form_Load()
Command1.DragMode = vbManual
End Sub
Hi is there any way I can change the mouse cursor in Visio programmatically?
I went through all the Automation classes in Visio SDK and could not find any related property, method, event....
-- Edit: Even while you can programmatically change the cursor, it seems that Visio (2003 in my computer) continuously restores the original cursor. I've tried it and, if I don't move the mouse, I can get a different cursor (like the hand) until I move the mouse, then it goes back to the arrow.
So, for now, my answer is: you can't change the cursor.
Maybe it is possible for other Visio versions.
You can use Windows API calls from your VBA code to change the cursor.
There is an example here: http://www.vbaexpress.com/kb/getarticle.php?kb_id=929
A better example, which I have got to work in Visio: http://www.tek-tips.com/viewthread.cfm?qid=1700789
And below, the code I have used for the testing environment:
First, create a "modCursor" module:
Option Explicit
'Declare Windows API Constants for Windows System cursors.
Public Const IDC_APPSTARTING = 32650& 'Standard arrow and small hourglass.
Public Const IDC_ARROW = 32512& 'Standard arrow.
Public Const IDC_CROSS = 32515 'Crosshair.
Public Const IDC_HAND = 32649 'Hand.
Public Const IDC_HELP = 32651 'Arrow and question mark.
Public Const IDC_IBEAM = 32513& 'Text I-beam.
Public Const IDC_ICON = 32641& 'Windows NT only: Empty icon.
Public Const IDC_NO = 32648& 'Slashed circle.
Public Const IDC_SIZE = 32640& 'Windows NT only: Four-pointed arrow.
Public Const IDC_SIZEALL = 32646& 'Four-pointed arrow pointing north, south, east, and west.
Public Const IDC_SIZENESW = 32643& 'Double-pointed arrow pointing northeast and southwest.
Public Const IDC_SIZENS = 32645& 'Double-pointed arrow pointing north and south.
Public Const IDC_SIZENWSE = 32642& 'Double-pointed arrow pointing northwest and southeast.
Public Const IDC_SIZEWE = 32644& 'Double-pointed arrow pointing west and east.
Public Const IDC_UPARROW = 32516& 'Vertical arrow.
Public Const IDC_WAIT = 32514& 'Hourglass.
'Declarations for API Functions.
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
'Declare handles for cursor.
Private hOldCursor As Long
Private hNewCursor As Long
'The UseCursor function will load and set a system cursor or a cursor from file to a
'controls event property.
Public Function UseCursor(ByVal NewCursor As Variant)
'Load new cursor.
Select Case TypeName(NewCursor)
Case "String" 'Custom cursor from file.
hNewCursor = LoadCursorFromFile(NewCursor)
Case "Long", "Integer" 'System cursor.
hNewCursor = LoadCursor(ByVal 0&, NewCursor)
Case Else 'Do nothing
End Select
'If successful set new cursor.
If (hNewCursor > 0) Then
hOldCursor = SetCursor(hNewCursor)
End If
'Clean up.
hOldCursor = DestroyCursor(hNewCursor)
hNewCursor = DestroyCursor(hOldCursor)
End Function
Second, create a Class Module, "MouseListener":
Option Explicit
Dim WithEvents vsoWindow As Window
Private Sub Class_Initialize()
Set vsoWindow = ActiveWindow
End Sub
Private Sub Class_Terminate()
Set vsoWindow = Nothing
End Sub
Private Sub vsoWindow_MouseDown(ByVal Button As Long, ByVal KeyButtonState As Long, ByVal x As Double, ByVal y As Double, CancelDefault As Boolean)
If Button = 1 Then
Debug.Print "Left mouse button clicked"
ElseIf Button = 2 Then
Debug.Print "Right mouse button clicked"
ElseIf Button = 16 Then
Debug.Print "Center mouse button clicked"
End If
End Sub
Private Sub vsoWindow_MouseMove(ByVal Button As Long, ByVal KeyButtonState As Long, ByVal x As Double, ByVal y As Double, CancelDefault As Boolean)
Debug.Print "x-position is "; x
Debug.Print "y-position is "; y
modCursor.UseCursor modCursor.IDC_HAND
End Sub
Private Sub vsoWindow_MouseUp(ByVal Button As Long, ByVal KeyButtonState As Long, ByVal x As Double, ByVal y As Double, CancelDefault As Boolean)
If Button = 1 Then
Debug.Print "Left mouse button released"
modCursor.UseCursor modCursor.IDC_HAND
ElseIf Button = 2 Then
Debug.Print "Right mouse button released"
modCursor.UseCursor modCursor.IDC_ARROW
ElseIf Button = 16 Then
Debug.Print "Center mouse button released"
End If
End Sub
Third, insert the following code into the "ThisDocument" module:
Private myMouseListener As MouseListener
Private Sub Document_DocumentSaved(ByVal doc As IVDocument)
Set myMouseListener = New MouseListener
End Sub
Private Sub Document_BeforeDocumentClose(ByVal doc As IVDocument)
Set myMouseListener = Nothing
End Sub
Now, by moving the mouse and clicking the buttons you get some information in the immediate window.
If you click the left button, the cursor changes to the hand, but when you move the mouse again, the cursor changes back. The only explanation I can think of is that Visio's events are changing the cursor icon depending on the (visual) context.
Regards,