VB备忘录（13）鼠标键盘

鼠标

改变光标

LoadCursorFromFile 载入光标图形，返回一个句柄。（这个句柄用SetClassLong，可以将其设置为某个对象中的光标）

DestoryCursor 卸载光标句柄，用默认

SetClassLong 设置目的对象内的光标

Option Explicit
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long,ByVal nIndex As Long,ByVal dwNewLong As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long

Private Const GCL_HCURSOR = (-12)    '指向这个类窗口默认光标的句柄,用括号防止减号与负号的混淆
Dim AniCur As Long

Private Sub Command1_Click()
    AniCur = LoadCursorFromFile("D:\SoftDev\22个漂亮动画光标\026.ani") '根据文件创建一个鼠标指针，返回该指针的句柄
    SetClassLong Me.hwnd,GCL_HCURSOR,AniCur     '在窗体上设置这个句柄为当前鼠标指针（形状）
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DestroyCursor AniCur   '删除创建的指针
End Sub

鼠标的常数：Button来标明是哪个键 vbLeftButton(1),vbRightButton(2),vbMiddleButton(4)

限定鼠标在范围内移动。

注意：若程序失误中，用程序快捷键停止调试，否则。。。。

Option Explicit
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long

Private Type RECT    '用户自定义类型
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Dim mouse As RECT

Private Sub Command1_Click()    '显示鼠标
    mouse.Left = Me.Left / Screen.TwipsPerPixelX
    mouse.Top = Me.Top / Screen.TwipsPerPixelY
    mouse.Right = (Me.Left + Me.Width) / Screen.TwipsPerPixelX
    mouse.Bottom = (Me.Top + Me.Height) / Screen.TwipsPerPixelY
    ClipCursor mouse
End Sub

Private Sub Command2_Click()
    Call UnMouse
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call UnMouse
End Sub

Private Sub UnMouse()    '解除锁定
    mouse.Left = 0
    mouse.Top = 0
    mouse.Right = (Screen.Width) / Screen.TwipsPerPixelX
    mouse.Bottom = (Screen.Height) / Screen.TwipsPerPixelY
    ClipCursor mouse  '整个屏幕的矩形
End Sub

键盘

设置KeyPreview,截获键盘，在其它控件前截获键盘事件（command例外）

command的default为真，接收回键触发，cancel为真接收ESC键触发

常数：vbKey

拖动

窗体内的控件可以拖动到另一位置，控件的内容也可以拖动到另一位置。

拖动有两种模式：手动拖动和自动拖动。 DragMode: 0-Manual,1-Automatic

拖动还有两个内容：控件或者内容。这里分拖动起源的控件（OLEDragMode），拖动至目的地控件（OLEDropMode)

一直是Drag，一个是Drop，搞反了会出错。

手动时须代码进行激活拖动动作：

控件： Drag 动作（一般是手动时用这个，自动亦可用）

动作有三种：0-vbDragCancel

1-vbDragBeginDrag

2-vbDragEndDrag

事件有：DragDrop(拖放放下时） DragOver（拖放经过时）

例： form1.drag vbdragbegindrag '开始拖动

当拖动控件时，该控件不能识别用户发出的其它鼠标或键盘事件（KeyDown、KeyPress 或 KeyUp，MouseDown、MouseMove 或 MouseUp)。

源：被拖动的控件称源控件

目：被放置的控件称为目控件

当源控件点击鼠标开始拖动时，会触发OLEstartDrag,然后是 drag,经过时dragover.

当源控件进入目的控件的方框内时，释放鼠标时，目的控件的drop就触发，若没进入方框内，窗体将成为目标。

控件的自动拖动

在窗体上添加command1,设置command1的dragmode为1(Automatic)即自动

Private Sub Form_DragDrop(Source As Control,X As Single,Y As Single)
    Source.Move (X - Source.Width / 2),(Y - Source.Height / 2)
End Sub

控件的手动拖动

窗体上添加command1,image1,在右下角放picture1,分别弄上图片。

Dim dx As Long
Dim dy As Long
Dim l As Long
Dim t As Long
'本例演示image1手动拖放
Private Sub Form_Load() '保存原始位置
    l = Image1.Left
    t = Image1.Top
    Command1.Visible = False
End Sub

Private Sub Form_DragDrop(Source As Control,Y As Single) '窗体上的拖放，是窗体在触发（不是控件）
    Source.Move X - dx,Y - dy
End Sub

Private Sub Image1_MouseDown(Button As Integer,Shift As Integer,Y As Single) '手动开始启动拖放
    dx = X
    dy = Y
    Image1.Drag vbBeginDrag
End Sub

Private Sub Picture1_DragDrop(Source As Control,Y As Single) '手动停止拖放，承受者picture1在触发
    Source.Drag vbEndDrag
    Source.Visible = False
    Picture1.Picture = LoadPicture("C:\Program Files\Microsoft Visual Studio\COMMON\Graphics\Icons\Computer\disk02.ico")
    Command1.Visible = True
End Sub

Private Sub Command1_Click() '恢复原状
    Image1.Drag vbdragcancel
    Image1.Left = l
    Image1.Top = t
    Image1.Visible = True
    Image1.Picture = LoadPicture("C:\Program Files\Microsoft Visual Studio\COMMON\Graphics\Icons\Computer\disk03.ico")
    Picture1.Picture = LoadPicture("C:\Program Files\Microsoft Visual Studio\COMMON\Graphics\Icons\Computer\disk04.ico")
    Command1.Visible = False
End Sub

内容的自动拖放

把一个控件内的内容播放至另一个控件内

窗体内把text1中的内容拖放到另一个text2中。（注意，按住Ctrl就会是复制，不按则是剪贴过来）

这个最简单：直接设置text1的OLEDragMode为Automatic（即起源自动），把text2的OLEDropMode设置为Automatic（即目的自动），

这样就完成了自动播放操作。有些没有这些属性的，须手动进行设置。

内容的手动拖动

这个最复杂，拖动的是内容，这个内容被看作对象即：DataObject

DataObject有OLEDrag,GetData,SetData,Clear等方法

内容手动拖放的事件有：

OLEDragDrop: 源内容放到目标内容时（视觉上是控件，这里用内容代）

OLEDragOver：源内容在另一内容上经过时

OLEStartDrag：OLEDrag执行时，或OLEdragMode设置为自动时，部件初始化操作发生。常用于指定源部件支持的数据格式和拖放效果

OLECompleteDrag：源部件放于目标部件时发生（并通知部件拖放操作被执行或取消（可在此事件中处理拖放结果，恢复资源等）

OLESetData：目标部件在DataObject对象上执行GetData方法时，但是还没有加载规定格式的数据时，在源部件上发生。

窗体上放两文本框，设置为手动

text1的OLEDragMode设置为自动，text2的OLeDropMOde设置为自动

Dim seleffect As Integer    '拖放效果
Private Sub Text1_MouseUp(Button As Integer,Y As Single)
    If Text1.SelLength > 0 And Button > 0 Then
        Text1.OLEDrag  '启动拖放
    End If
End Sub

Private Sub Text1_OLECompleteDrag(Effect As Long)
    If Effect = vbDropEffectMove Then  '移动方式时，源处清除
        Text1.SelText = ""
    End If
End Sub

Private Sub Text1_OLEDragOver(Data As DataObject,Effect As Long,Button As Integer,Y As Single,State As Integer)
    Select Case Button
    Case 1  '左键
        Effect = Effect And vbDropEffectMove
    Case 2  '右键
        Effect = Effect And vbDropEffectCopy
    Case Is > 2
        Effect = vbDropEffectNone
    Case Else
        seleffect = Effect
    End Select
End Sub

Private Sub Text1_OLESetData(Data As DataObject,DataFormat As Integer)
    Data.SetData Text1.SelText,DataFormat '设置数据
End Sub

Private Sub Text1_OLEStartDrag(Data As DataObject,AllowedEffects As Long)
    AllowedEffects = vbDropEffectCopy Or vbDropEffectMove
    Data.Clear
    Data.SetData,vbCFText '设置文本格式
End Sub


Private Sub Text2_GotFocus()
    Text2.SelLength = 0
End Sub

Private Sub Text2_OLEDragDrop(Data As DataObject,Y As Single)
    If Data.GetFormat(vbCFText) Then
        Text2.SelText = Data.GetData(vbCFText) '取得数据
        Effect = seleffect
    Else
        Effect = vbDropEffectNone  '非文本时拒绝
    End If
End Sub

Private Sub Text2_OLEDragOver(Data As DataObject,State As Integer)
    Select Case Button
    Case 1
        Effect = Effect And vbDropEffectMove
    Case 2
        Effect = Effect And vbDropEffectCopy
    Case Is > 2
        Effect = vbDropEffectNone
    Case Else
        seleffect = Effect
    End Select
End Sub

原文链接：https://www.f2er.com/vb/259036.html

VB备忘录（13） 鼠标键盘

猜你在找的VB相关文章

VB备忘录（13）鼠标键盘