玩酷之家

 找回密码
 立即注册
查看: 137|回复: 0

VB 仿QQ自动隐藏效果

[复制链接]
发表于 2020-12-19 23:11:13 | 显示全部楼层 |阅读模式
本帖最后由 Ineverleft 于 2020-12-19 23:28 编辑

在窗体中添加两个Timer,分别命名为:tmrCheck,Interval为50;tmrMove,Interval为1;两个Timer的Enable均为False。
类模块命名为:iSubClass
  1. 'iSubClass类模块
  2. Option Explicit
  3. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
  4. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  5. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  6. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  7. Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
  8. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  9. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
  10. Private Declare Function GetProcessHeap Lib "kernel32" () As Long
  11. Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
  12. Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long

  13. Private Type ThisClassSet
  14.     s_srcWndProcAddress     As Long
  15.     s_Hwnd                  As Long
  16.    
  17.     n_heapAlloc             As Long
  18. End Type
  19. Dim LinkProc(29)  As Long
  20. Dim PG                      As ThisClassSet

  21. Event GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)

  22. Private Sub MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
  23.     '子类化接口过程
  24.     RaiseEvent GetWindowMessage(Result, cHwnd, Message, wParam, lParam)
  25. End Sub

  26. Private Function GetWndProcAddress(ByVal OrgWindowProc As Long, ByVal SinceCount As Long) As Long
  27. '   地址指针 = GetWndProcAddress( 取第 N 个公共函数(属性)  =或= 所有公共函数个数 + 第 N 个私有函数的函数地址)
  28.     Dim mePtr As Long
  29.     Dim jmpAddress As Long
  30.     Dim i As Long
  31.     Dim Protlng As Long
  32.    
  33.     mePtr = ObjPtr(Me)
  34.     CopyMemory jmpAddress, ByVal mePtr, 4
  35.     CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4

  36.    
  37.     LinkProc(0) = &H83EC8B55
  38.     LinkProc(1) = &H75FFFCC4
  39.     LinkProc(2) = &H1075FF14
  40.     LinkProc(3) = &HFF0C75FF
  41.     LinkProc(4) = &HB80875
  42.     LinkProc(5) = &HB000040
  43.     LinkProc(6) = &HB94575C0
  44.     LinkProc(7) = &H1000&
  45.     LinkProc(8) = &H830C458B
  46.     LinkProc(9) = &H87502F8
  47.     LinkProc(10) = &H1C7&
  48.     LinkProc(11) = &H1BEB0000
  49.     LinkProc(12) = &H863D&
  50.     LinkProc(13) = &H8B077500
  51.     LinkProc(14) = &H1891045
  52.     LinkProc(15) = &H5A3D0DEB
  53.     LinkProc(16) = &H75000010
  54.     LinkProc(17) = &H101C706
  55.     LinkProc(18) = &H83000000
  56.     LinkProc(19) = &H2750139
  57.     LinkProc(20) = &H680EEB
  58.     LinkProc(21) = &HB8000020
  59.     LinkProc(22) = &H3000&
  60.     LinkProc(23) = &H13EBD0FF
  61.     LinkProc(24) = &H50FC458D
  62.     LinkProc(25) = &H500068
  63.     LinkProc(26) = &H6000B800
  64.     LinkProc(27) = &HD0FF0000
  65.     LinkProc(28) = &HC9FC458B
  66.     LinkProc(29) = &H10C2&
  67.         
  68.     i = App.LogMode
  69.     CopyMemory ByVal VarPtr(LinkProc(4)) + 3, i, 4&                                     ' Label Sign: 0400000
  70.     CopyMemory ByVal VarPtr(LinkProc(25)) + 1, mePtr, 4&                                ' Label Sign: 0500000
  71.     CopyMemory ByVal VarPtr(LinkProc(26)) + 2, jmpAddress, 4&                           ' Label Sign: 0600000
  72.    
  73.     If i Then
  74.         i = VarPtr(LinkProc(0))
  75.         Protlng = 120
  76.     Else
  77.         PG.n_heapAlloc = HeapAlloc(GetProcessHeap, &H8, 128&)
  78.         CopyMemory ByVal PG.n_heapAlloc + 120&, 1&, 4
  79.         LinkProc(7) = PG.n_heapAlloc + 120                                                  ' Label Sign: 0100000
  80.         CopyMemory ByVal VarPtr(LinkProc(20)) + 3, OrgWindowProc, 4&                        ' Label Sign: 0200000
  81.         LinkProc(22) = GetProcAddress(GetModuleHandle("user32.dll"), "CallWindowProcA")     ' Label Sign: 0300000
  82.         
  83.         CopyMemory ByVal PG.n_heapAlloc&, LinkProc(0), 120&
  84.         i = PG.n_heapAlloc
  85.         Protlng = 128
  86.     End If
  87.    
  88.     VirtualProtect ByVal i&, Protlng, &H40, mePtr
  89.     GetWndProcAddress = i
  90. End Function

  91. Function CallDefaultWindowProc(ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  92.     '调用窗口默认处理过程
  93.     CallDefaultWindowProc = CallWindowProc(PG.s_srcWndProcAddress, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
  94. End Function

  95. Function SetMsgHook(ByVal cHwnd As Long) As Long
  96.     '设置指定窗口的子类化
  97.     PG.s_Hwnd = cHwnd
  98.     PG.s_srcWndProcAddress = GetWindowLong(cHwnd, ByVal -4&)
  99.     SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(PG.s_srcWndProcAddress, 4)
  100.     SetMsgHook = PG.s_srcWndProcAddress
  101. End Function

  102. Sub SetMsgUnHook()
  103.     '取消窗口子类化
  104.     SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_srcWndProcAddress&
  105. End Sub


复制代码
  1. '窗体代码
  2. Option Explicit
  3. '//本功能代码作者   gvu
  4. '//子类化代码作者   pctgl
  5. '//版权归作者所有
  6. '//转载请保留作者信息

  7. Private Const WM_NCLBUTTONDOWN = &HA1
  8. Private Const WM_EXITSIZEMOVE = &H232
  9. Private Const WM_MOVING = &H216
  10. Private Type RECT
  11.         Left As Long
  12.         Top As Long
  13.         Right As Long
  14.         Bottom As Long
  15. End Type
  16. Private Type POINTAPI
  17.         X As Long
  18.         Y As Long
  19. End Type
  20. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  21. Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
  22. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  23. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

  24. Private WithEvents c_Subclass   As iSubClass

  25. Private Const SIZE_SHOW         As Long = 60    '隐藏后留出来的宽度或高度,单位缇
  26. Private Const SHOWHIDE_SPEED    As Long = 30    '(自动显示隐藏速度,单位缇)
  27. '显示标识
  28. '0  自动隐藏
  29. '1  自动显示
  30. Private m_ShowFlag              As Long
  31. '显示方向
  32. '0  向左
  33. '1  向右
  34. '2  向上
  35. Private m_ShowOrient            As Long
  36. '显示速度
  37. Private m_ShowSpeed             As Long
  38. '是否已经启动自动隐藏(为了防止WM_MOVING调整窗口位置)
  39. Private m_MoveEnabled           As Boolean

  40. '//下面是把窗口移动Top=0且Left=0或Right=Screen.Width的时候让窗口高度=屏幕高度
  41. '是否自动调整了大小
  42. Private m_AutoSize              As Boolean
  43. Private m_OldHeight             As Long

  44. Private Sub Form_Load()
  45.    Set c_Subclass = New iSubClass
  46.    c_Subclass.SetMsgHook Me.hWnd
  47. End Sub

  48. Private Sub c_Subclass_GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
  49.     Select Case Message
  50.         Case WM_NCLBUTTONDOWN
  51.             Const HTCAPTION = 2
  52.             If wParam = HTCAPTION Then
  53.                 '点击标题栏让所有Timer停止工作
  54.                 m_MoveEnabled = True
  55.                 tmrCheck.Enabled = False
  56.                 tmrMove.Enabled = False
  57.             End If
  58.             
  59.         Case WM_MOVING
  60.             If m_MoveEnabled = False Then Exit Sub
  61.             '这里仅仅是为了不让窗口移出屏幕,可以忽略
  62.             Dim rcMov   As RECT
  63.             Dim rcWnd   As RECT
  64.             Dim lScrW   As Long
  65.             '获取窗口矩形
  66.             Call GetWindowRect(cHwnd, rcWnd)
  67.             '//屏幕宽度
  68.             lScrW = Screen.Width / Screen.TwipsPerPixelX
  69.             '获取移动目标位置矩形
  70.             Call CopyMemory(rcMov, ByVal lParam, Len(rcMov))
  71.             With rcMov
  72.                 If .Left < 0 Then
  73.                     .Left = 0
  74.                     .Right = rcWnd.Right - rcWnd.Left
  75.                 End If
  76.                 If .Top < 0 Then
  77.                     .Top = 0
  78.                     .Bottom = rcWnd.Bottom - rcWnd.Top
  79.                 End If
  80.                 If .Right > lScrW Then
  81.                     .Left = lScrW - (rcWnd.Right - rcWnd.Left)
  82.                     .Right = .Left + (rcWnd.Right - rcWnd.Left)
  83.                 End If
  84.             End With
  85.             '//如果窗口的靠在右上角或左上角,则把高度设置为屏幕高度
  86.             If rcMov.Top = 0 And (rcMov.Left = 0 Or rcMov.Right = Screen.Width / Screen.TwipsPerPixelX) Then
  87.                 If m_AutoSize = False Then
  88.                     m_AutoSize = True
  89.                     '保存旧的高度
  90.                     m_OldHeight = rcMov.Bottom - rcMov.Top
  91.                     rcMov.Bottom = Screen.Height / Screen.TwipsPerPixelY
  92.                 End If
  93.             Else
  94.                 If m_AutoSize Then
  95.                     m_AutoSize = False
  96.                     '设置旧的高度
  97.                     rcMov.Bottom = rcMov.Top + m_OldHeight
  98.                 End If
  99.             End If
  100.             Call CopyMemory(ByVal lParam, rcMov, Len(rcMov))
  101.             
  102.         Case WM_EXITSIZEMOVE
  103.             m_MoveEnabled = False
  104.             Call GetWindowRect(cHwnd, rcWnd)
  105.             If rcWnd.Left <= 0 Or rcWnd.Top <= 0 Or _
  106.                 rcWnd.Right >= Screen.Width / Screen.TwipsPerPixelX Then
  107.                 '如果窗口停靠在屏幕边缘
  108.                 '让检查鼠标位置的Timer工作
  109.                
  110.                 '设置显示方向
  111.                 If rcWnd.Left = 0 Then
  112.                     m_ShowOrient = 0
  113.                 ElseIf rcWnd.Right >= Screen.Width / Screen.TwipsPerPixelX Then
  114.                     m_ShowOrient = 1
  115.                 ElseIf rcWnd.Top = 0 Then
  116.                     m_ShowOrient = 2
  117.                 End If
  118.                 tmrCheck.Enabled = True
  119.             End If
  120.     End Select
  121.     Result = c_Subclass.CallDefaultWindowProc(cHwnd, Message, wParam, lParam)
  122. End Sub

  123. Private Sub tmrCheck_Timer()
  124.     Dim pt As POINTAPI
  125.     Dim rc As RECT
  126.     Call GetCursorPos(pt)
  127.     Call GetWindowRect(Me.hWnd, rc)
  128.     If PtInRect(rc, pt.X, pt.Y) Then
  129.         '鼠标停留在窗口上
  130.         If m_ShowFlag = 1 Then Exit Sub
  131.         m_ShowSpeed = SHOWHIDE_SPEED
  132.         m_ShowFlag = 1
  133.         tmrMove.Enabled = True
  134.     Else
  135.         '鼠标不再窗口上
  136.         If m_ShowFlag = 0 Then Exit Sub
  137.         m_ShowSpeed = SHOWHIDE_SPEED
  138.         m_ShowFlag = 0
  139.         tmrMove.Enabled = True
  140.     End If
  141. End Sub

  142. Private Sub tmrMove_Timer()
  143.     Dim nTop    As Long
  144.     Dim nLeft   As Long
  145.     m_ShowSpeed = m_ShowSpeed + SHOWHIDE_SPEED
  146.     '如果大于300T则加快速度
  147.     If m_ShowSpeed > 300 Then m_ShowSpeed = m_ShowSpeed + m_ShowSpeed * 0.2
  148.     Select Case m_ShowOrient
  149.         Case 0  '0  向左
  150.             If m_ShowFlag = 0 Then
  151.                 nLeft = Me.Left - m_ShowSpeed
  152.                 If nLeft < -Me.Width + SIZE_SHOW Then nLeft = -Me.Width + SIZE_SHOW: tmrMove.Enabled = False
  153.             Else
  154.                 nLeft = Me.Left + m_ShowSpeed
  155.                 If nLeft > -SIZE_SHOW Then nLeft = -SIZE_SHOW: tmrMove.Enabled = False
  156.             End If
  157.             Me.Left = nLeft
  158.             
  159.         Case 1  '1  向右
  160.             If m_ShowFlag = 0 Then
  161.                 nLeft = Me.Left + m_ShowSpeed
  162.                 If nLeft > Screen.Width - SIZE_SHOW Then nLeft = Screen.Width - SIZE_SHOW: tmrMove.Enabled = False
  163.             Else
  164.                 nLeft = Me.Left - m_ShowSpeed
  165.                 If nLeft < Screen.Width - Me.Width + SIZE_SHOW Then nLeft = Screen.Width - Me.Width + SIZE_SHOW: tmrMove.Enabled = False
  166.             End If
  167.             Me.Left = nLeft
  168.             
  169.         Case 2  '2  向上
  170.             If m_ShowFlag = 0 Then
  171.                 nTop = Me.Top - m_ShowSpeed
  172.                 If nTop < -Me.Height + SIZE_SHOW Then nTop = -Me.Height + SIZE_SHOW: tmrMove.Enabled = False
  173.             Else
  174.                 nTop = Me.Top + m_ShowSpeed
  175.                 If nTop > -SIZE_SHOW Then nTop = -SIZE_SHOW: tmrMove.Enabled = False
  176.             End If
  177.             Me.Top = nTop
  178.             
  179.     End Select
  180. End Sub
复制代码


回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|Archiver|手机版|小黑屋|玩酷之家 ( 鄂ICP备14012049号 )

GMT+8, 2021-1-25 08:55 , Processed in 1.123202 second(s), 17 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表