QQ祝福语

 

'**************************************************************************
'**模 块 名：QQ祝福 - Form1
'**说 明：永远的魔灵 by icecept(郭卫）
'**创 建 人：icecept(魔灵)
'**日 期：2009-03-29 02:40:34
'**修 改 人：icecept(魔灵)
'**版 本：V1.0.0
'**E-mail   ：icecept@163.com QQ：543375508
'**网 址：http://hi.baidu.com/icecept    http://hi.csdn.net/icecept
'*************************************************************************
Private Sub Form_Load()
Dim hKey As Long, ret As Long    '打开键的句柄
Dim Name As String * 255, lngTypeData As Long
Dim intname1 As Integer
RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE/MICROSOFT/WINDOWS/CURRENTVERSION/RUN", hKey
RegQueryValueEx hKey, App.EXEName, 0&, lngTypeData, ByVal Name, Len(Name)
'返回command项App.EXEName
intname1 = InStr(Name, App.EXEName & ".exe")
If intname1 = 0 Then
       '打开注册表项,设置自启动项目
       ret = RegSetValueEx(hKey, App.EXEName, 0, REG_SZ, ByVal CheckFilePath(App.Path) & App.EXEName & ".exe", LenB(CheckFilePath(App.Path) & App.EXEName & ".exe") + 1)
       '关闭注册表项
       RegCloseKey hKey
End If
If App.PrevInstance = True Then End
App.TaskVisible = False '隐藏程序
HideCurrentProcess        '隐藏进程
'注册 Ctrl+Shift+Y 为热键
RegisterHotKey Me.hWnd, &HBFFF&, MOD_CONTROL + MOD_SHIFT, vbKeyY
'等待处理消息
HotKey_Flg = False
Do While Not HotKey_Flg
       '等待消息
       WaitMessage
       '检查是否热键被按下
       If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
         '打开本程序
         Me.Show
         Me.WindowState = vbNormal
       End If
       '转让控制权,允许操作系统处理其他事件
       DoEvents
Loop
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Dim dl As Long
Dim FormCaption As String
FormCaption = Space(128)
dl& = GetWindowText(GetForegroundWindow, FormCaption, 128)
i = InStrRev(FormCaption, "群")
If Not i = 0 Then
       SendMsText
       Exit Sub
End If
i = InStrRev(FormCaption, "中")
If Not i = 0 Then
       SendMsText
       Exit Sub
End If
End Sub
Sub SendMsText()
On Error Resume Next
Randomize
score = Rnd * (List1.ListCount - "1") + "1"
List1.ListIndex = score
SendKeys List1.Text
SendKeys "%S"
DoEvents
End Sub
Private Function CheckFilePath(Path As String) As String
'检查档位文件是否在根目录下
If Right(Path, 1) <> "/" Then
       CheckFilePath = Path & "/"
Else
       CheckFilePath = Path
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
HotKey_Flg = True
'撤销热键的注册
Call UnregisterHotKey(Me.hWnd, &HBFFF&)
End Sub
Private Sub Command1_Click()
Timer1.Enabled = True
Me.WindowState = vbMinimized
Me.Hide
End Sub
Private Sub Command2_Click()
Timer1.Enabled = False
Me.WindowState = vbMinimized
Me.Hide
End Sub

附件: QQ祝福语.rar

 

                                                                                                                                                    

永远的魔灵<icecept> by 郭卫

http://icecept.jimdo.com