ps：刚刚发过一个贴，可是出现“单表提交错误”，不知成没成功所以再发一遍...
1、申 请 I D ：小歆
2、个人邮箱：zhangzejin3883@163.com
3、自我简单介绍及主要作品链接： 本人是学电子的在校大学生，爱好VB，C，脚本等，现在还在学一些单片机和汇编的知识；这几天用VB写了个挂QQ的工具，贴出来交流一下啊！
4、申请时间：2012年6月20日
5、备注：请管理人员审核，谢谢！
6、作品：
command四个1，2，4，5
text六个，label六个（一一对应）
定时器两个timer1（开启，200毫秒）和QQtime（开启，60000毫秒）
源码如下：
（说明一下SID的获取，要通过wap登陆QQ后，查看地址即可看到“sid=....&”把“=”和“&”直接的代码粘贴到文本框里就OK啦！）Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long '热键声明
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '延时声明
Dim qt, int_End As Integer
Private Sub Command1_Click()
Dim msg1 As Integer
If QQtime.Enabled = False Then
QQtime.Enabled = True
Command1.Caption = "停止挂机"
Text1.Enabled = False
Text2.Enabled = False
Text3.Enabled = False
Text4.Enabled = False
Text5.Enabled = False
Text6.Enabled = False
Command3.Enabled = False
QQgj
Else
msg1 = MsgBox("注：停止挂机后30分钟内被挂机QQ将下线！", vbInformation, "提示")
QQtime.Enabled = False
Command1.Caption = "开始挂机"
Text1.Enabled = True
Text2.Enabled = True
Text3.Enabled = True
Text4.Enabled = True
Text5.Enabled = True
Text6.Enabled = True
Command3.Enabled = True
End If
End Sub
Private Sub Command2_Click()
SendKeys vbTab '解决按钮出现虚线框
Dim int_Exit As Integer
int_Exit = MsgBox("您是要隐藏工具窗体？ ", vbYesNo, "提示 ")
If int_Exit = vbYes Then
Me.Visible = Not Me.Visible '窗体可见不可见
Cancel = -1 ' 取消退出操作
Else
int_End = MsgBox("您确定要退出挂机工具吗？如果退出将停止一切挂机活动！ ", vbYesNo, "提示 ")
If int_End = vbYes Then
Set Form1 = Nothing
End
Else
Cancel = -1 ' 取消退出操作
End If
End If
End Sub
Private Sub Command4_Click()
If Command6.Top < 3600 Then '高度差480
Command4.Top = Command4.Top + 480
Command5.Top = Command5.Top + 480
Command6.Top = Command6.Top + 480
Me.Height = Me.Height + 480
If Command6.Top = 1680 Then
Label2.Visible = True
Text2.Visible = True
ElseIf Command6.Top = 2160 Then
Label3.Visible = True
Text3.Visible = True
ElseIf Command6.Top = 2640 Then
Label4.Visible = True
Text4.Visible = True
ElseIf Command6.Top = 3120 Then
Label5.Visible = True
Text5.Visible = True
ElseIf Command6.Top = 3600 Then
Label6.Visible = True
Text6.Visible = True
Command4.Enabled = False
End If
End If
Command5.Enabled = True
SendKeys vbTab '解决按钮出现虚线框
End Sub
Private Sub Command5_Click()
If Command6.Top > 1200 Then '高度差480
Command4.Top = Command4.Top - 480
Command5.Top = Command5.Top - 480
Command6.Top = Command6.Top - 480
Me.Height = Me.Height - 480
If Command6.Top = 1200 Then
Label2.Visible = False
Text2.Visible = False
Command5.Enabled = False
ElseIf Command6.Top = 1680 Then
Label3.Visible = False
Text3.Visible = False
ElseIf Command6.Top = 2160 Then
Label4.Visible = False
Text4.Visible = False
ElseIf Command6.Top = 2640 Then
Label5.Visible = False
Text5.Visible = False
ElseIf Command6.Top = 3120 Then
Label6.Visible = False
Text6.Visible = False
End If
End If
Command4.Enabled = True
SendKeys vbTab '解决按钮出现虚线框
End Sub
Private Sub Form_Load()
If App.PrevInstance = True Then
SendKeys vbKeyEscape
End
End If
Command4.Top = 1200
Command5.Top = 1200
Command6.Top = 1200
Me.Height = 2055
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Me.Visible = Not Me.Visible '窗体可见不可见
Cancel = -1
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Form1 = Nothing
End
End Sub
Private Sub QQtime_Timer()
Dim i As Integer
If qt = 0 Then
QQgj
End If
qt = qt + 1
If qt = 20 Then qt = 0
End Sub
Private Sub Timer1_Timer()
'检查是否热键被按下
If GetAsyncKeyState(vbKeyEscape) Then Me.Visible = Not Me.Visible '按下 ESC 键让窗体可见或不可见
If GetAsyncKeyState(vbKeyEnd) Then '按下END 退出程序
int_End = MsgBox("您确定要退出挂机工具吗？如果退出将停止一切挂机活动！ ", vbYesNo, "提示 ")
If int_End = vbYes Then
Set Form1 = Nothing
End
Else
Cancel = -1
End If
End If
End Sub
Public Function QQgj()
For i = 0 To 5
If i = 0 Then
sid = Text1.Text
ElseIf i = 1 Then
sid = Text2.Text
Sleep 5000
ElseIf i = 2 Then
sid = Text3.Text
Sleep 5000
ElseIf i = 3 Then
sid = Text4.Text
Sleep 5000
ElseIf i = 4 Then
sid = Text5.Text
Sleep 5000
ElseIf i = 5 Then
sid = Text6.Text
Sleep 5000
End If
If sid = "" Then
Exit For
End If
With CreateObject("Msxml2.ServerXMLHTTP")
.open "POST", "http://pt.3g.qq.com/s?aid=nLogin3gqqbysid&r=" & Rnd, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "auto=1&loginType=1&3gqqsid=" & sid
End With
Next i
End Function
| 
[复制链接]
吾爱游客
发表于 2012-6-20 17:54
发表于 2012-6-21 11:08
