返回列表 发帖
感谢楼主。。。。。

TOP

好!我发源码给大家看看!!
窗口代码
  1. Option Explicit

  2. Dim IsDragging As Boolean

  3. Private Sub SetOnTop(ByVal IsOnTop As Integer)
  4. Dim rtn As Long
  5.     If IsOnTop = 1 Then
  6.         '将窗口置于最上面
  7.         rtn = SetWindowPos(frmMain.hwnd, -1, 0, 0, 0, 0, 3)
  8.     Else
  9.         rtn = SetWindowPos(frmMain.hwnd, -2, 0, 0, 0, 0, 3)
  10.     End If
  11. End Sub

  12. Private Sub Check1_Click()
  13.     SetOnTop (Check1.Value)
  14. End Sub

  15. Private Sub Form_Load()
  16.     Check1.Value = 1
  17.     SetOnTop (Check1.Value)
  18.     IsDragging = False
  19. End Sub

  20. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  21. If IsDragging = True Then
  22.     Dim rtn As Long, curwnd As Long
  23.     Dim tempstr As String
  24.     Dim strlong As Long
  25.     Dim point As POINTAPI
  26.     point.x = x
  27.     point.y = y
  28.     '将客户坐标转化为屏幕坐标并显示在PointText文本框中
  29.     If ClientToScreen(frmMain.hwnd, point) = 0 Then Exit Sub
  30.     PointText.Text = Str(point.x) + "," + Str(point.y)
  31.     '获得鼠标所在的窗口句柄并显示在hWndText文本框中
  32.     curwnd = WindowFromPoint(point.x, point.y)
  33.     hWndText.Text = Str(curwnd)
  34.     '获得该窗口的类型并显示在WndClassText文本框中
  35.     tempstr = Space(255)
  36.     strlong = Len(tempstr)
  37.     rtn = GetClassName(curwnd, tempstr, strlong)
  38.     If rtn = 0 Then Exit Sub
  39.     tempstr = Trim(tempstr)
  40.     WndClassText.Text = tempstr
  41.     '向该窗口发送一个WM_GETTEXT消息,以获得该窗口的文本,并显示在PasswordText文本框中
  42.     tempstr = Space(255)
  43.     strlong = Len(tempstr)
  44.     rtn = SendMessage(curwnd, WM_GETTEXT, strlong, tempstr)
  45.     tempstr = Trim(tempstr)
  46.     PasswordText.Text = tempstr
  47. End If
  48.    
  49. End Sub

  50. Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  51. If IsDragging = True Then
  52.     Screen.MousePointer = vbDefault
  53.     IsDragging = False
  54.     '释放鼠标消息抓取
  55.     ReleaseCapture
  56. End If
  57. End Sub

  58. Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  59. If IsDragging = False Then
  60.     IsDragging = True
  61.     Screen.MouseIcon = LoadPicture(App.Path + "\pass.ico")
  62.     Screen.MousePointer = vbCustom
  63.     '将以后的鼠标输入消息都发送到本程序窗口
  64.     SetCapture (frmMain.hwnd)
  65. End If
  66.    
  67. End Sub
复制代码
模板代码
  1. Option Explicit

  2. 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
  3. Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
  4. Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
  5. Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  6. Declare Function GetLastError Lib "kernel32" () As Long
  7. Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  8. Declare Function ReleaseCapture Lib "user32" () As Long
  9. Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

  10. Public Const WM_GETTEXT = &HD
  11. Type POINTAPI
  12.     x As Long
  13.     y As Long
  14. End Type
复制代码

TOP

回复 8# 噯伱╅詠吥變 的帖子

可以使用了
测试效果不错
开源.....

TOP

呵呵!不好意思!刚刚忘了打包ICO图标了!!

TOP

同样出现了2楼的情况

感谢楼主,不知能否开源

TOP

楼主检查下

TOP

楼主会写程序啊,羡慕

TOP

好像是有点问题

TOP

ico图标资源问题

TOP

附件: 您需要登录才可以下载或查看附件。没有帐号?注册

TOP

返回列表