发几个vb整人小程序代码.第一次发帖.希望大家多多支持
2009年12月25日
1楼
本人刚学vb一天而已.
找个几个整人的代码做着玩玩.
觉得还不错.
就发来给大家分享一下.
希望大家不要介意.
本人qq450721736.
喜欢vb的加我咯.
一起学习vb.
--------------------------------------------------
这个是关闭桌面所有窗口
(直接复制上去就ok)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Dim a(50) As Long
Dim I As Integer
Dim flag As Boolean
Private Sub Command1_Click()
flag = True
MsgBox "都叫你别冲动了.重启吧~"
End
End Sub
Private Sub Form_Load()
I = 0
flag = fase
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Text1 = "小鹏提醒你,别激动.!"
Cancel = True
End Sub
Private Sub Timer1_Timer()
Dim lg As Long
On Error Resume Next
Dim curhWnd As Long 'Current hWnd
Dim lp As POINTAPI
If flag = False Then Exit Sub
I = I + 1
If I 0 Then
h2 = GetDlgItem(h1, &H130)
If h2 0 Then
SetWindowText h2, "小鹏" '这里可以修改自己的文字
SendMessage h2, BM_CLICK, 0, ByVal 0&
End If
End If
End Sub
2009-9-26 16:21 回复
ww0034 0位粉丝 3楼
这个是翻转屏幕代码
(添加一个Timer)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Dim W As Long, H As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Sub Form_Load()
Dim DC As Long
Me.Move 0, 0, Screen.Width, Screen.Height
W = Screen.Width / 15: H = Screen.Height / 15
ShowCursor False
Me.Visible = True
DC = GetDC(0)
StretchBlt Me.hdc, W - 1, H - 1, -W, -H, DC, 0, 0, W, H, SRCCOPY
ReleaseDC 0, DC
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
ShowCursor True
End Sub
Private Sub Timer1_Timer()
StretchBlt Me.hdc, W - 1, H - 1, -W, -H, Me.hdc, 0, 0, W, H, SRCCOPY
Me.Refresh
End Sub
2009-9-26 16:21 回复
ww0034 0位粉丝 4楼
这个是关闭QQ的代码
(需要添加一个Command1.一个text1)
这个程序打包的时候,金山毒霸说是病毒
希望懂的帮我看一下
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_RESTORE = 9
Private Const SW_SHOW = 5
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPheaplist = &H1
Private Const TH32CS_SNAPthread = &H4
Private Const TH32CS_SNAPmodule = &H8
Private Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule
Private Const MAX_PATH As Integer = 260
Private Const PROCESS_TERMINATE = &H1
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Text1 = "想关点退出啊.怎么那么笨!"
Cancel = True
End Sub
Private Sub command1_Click()
Dim i As Long
Dim proc As PROCESSENTRY32
Dim snap As Long
Dim exename As String
Dim hand As Long, theloop As Long
snap = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) ':获得进程“快照”的句柄
proc.dwSize = Len(proc)
theloop = ProcessFirst(snap, proc) ':获取第一个进程,并得到其返回值
i = 0
While theloop 0 ':当返回值非零时继续获取下一个进程
exename = proc.szExeFile
If Left(LCase(exename), 6) = "qq.exe" Then
hand = OpenProcess(PROCESS_TERMINATE, True, proc.th32ProcessID) ':获取进程句柄
TerminateProcess hand, 0 ':关闭进程
End If
theloop = ProcessNext(snap, proc)
Wend
CloseHandle snap ':关闭进程“快照”句柄
MsgBox "真遗憾,您扣扣掉线了!"
End
End Sub
2009-9-26 16:22 回复
ww0034 0位粉丝 5楼
这个是爱不爱我代码,挺好玩的这个
(需要添加两个command)
Option Explicit
Private Sub Command1_GotFocus()
Command2.SetFocus
End Sub
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Randomize Timer
With Me
Command1.Move Rnd * (.ScaleWidth - Command1.Width), Rnd * (.ScaleHeight - Command1.Height)
End With
End Sub
Private Sub Command2_Click()
MsgBox "我也爱你!"
End
End Sub
Private Sub Form_Load()
Me.AutoRedraw = True
Me.FontSize = 30
Me.Print "你爱不爱我?"
Command1.Caption = "不爱"
Command2.Caption = "爱"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Cancel = 1
End Sub
2009-9-26 16:22 回复
ww0034 0位粉丝 6楼
应用软件
--------------------------------------------------
繁体简体转换
(需要添加4个Cammand.1个text)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Declare Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'简转繁
Public Function JToF(ByVal Str As String) As String
Dim STlen As Long
Dim STf As String
STlen = lstrlen(Str)
STf = Space(STlen)
LCMapString &H804, &H4000000, Str, STlen, STf, STlen
JToF = STf
End Function
'繁转简
Public Function FToJ(ByVal Str As String) As String
Dim STlen As Long
Dim STj As String
STlen = lstrlen(Str)
STj = Space(STlen)
LCMapString &H804, &H2000000, Str, STlen, STj, STlen
FToJ = STj
End Function
Private Sub Command1_Click()
Text1.Text = JToF(Text1.Text)
End Sub
Private Sub Command2_Click()
Text1.Text = FToJ(Text1.Text)
End Sub
Private Sub Command3_Click()
Text1.Text = ""
End Sub
Private Sub Command4_Click()
End
End Sub
--------------------------------------------------
打开我的电脑等
(需要添加5个Command)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
'我的文档
ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1
Case 1
'我的电脑
ShellExecute Me.hwnd, "open", "explorer", "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1
Case 2
'网上邻居
ShellExecute Me.hwnd, "open", "explorer", "::{208d2c60-3aea-1069-a2d7-08002b30309d}", vbNullString, 1
Case 3
'回收站
ShellExecute Me.hwnd, "open", "explorer", "::{645ff040-5081-101b-9f08-00aa002f954e}", vbNullString, 1
Case 4
'控制面板
ShellExecute Me.hwnd, "open", "explorer", "::{21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1
End Select
2009年12月25日
1楼
本人刚学vb一天而已.
找个几个整人的代码做着玩玩.
觉得还不错.
就发来给大家分享一下.
希望大家不要介意.
本人qq450721736.
喜欢vb的加我咯.
一起学习vb.
--------------------------------------------------
这个是关闭桌面所有窗口
(直接复制上去就ok)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Dim a(50) As Long
Dim I As Integer
Dim flag As Boolean
Private Sub Command1_Click()
flag = True
MsgBox "都叫你别冲动了.重启吧~"
End
End Sub
Private Sub Form_Load()
I = 0
flag = fase
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Text1 = "小鹏提醒你,别激动.!"
Cancel = True
End Sub
Private Sub Timer1_Timer()
Dim lg As Long
On Error Resume Next
Dim curhWnd As Long 'Current hWnd
Dim lp As POINTAPI
If flag = False Then Exit Sub
I = I + 1
If I 0 Then
h2 = GetDlgItem(h1, &H130)
If h2 0 Then
SetWindowText h2, "小鹏" '这里可以修改自己的文字
SendMessage h2, BM_CLICK, 0, ByVal 0&
End If
End If
End Sub
2009-9-26 16:21 回复
ww0034 0位粉丝 3楼
这个是翻转屏幕代码
(添加一个Timer)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Dim W As Long, H As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Sub Form_Load()
Dim DC As Long
Me.Move 0, 0, Screen.Width, Screen.Height
W = Screen.Width / 15: H = Screen.Height / 15
ShowCursor False
Me.Visible = True
DC = GetDC(0)
StretchBlt Me.hdc, W - 1, H - 1, -W, -H, DC, 0, 0, W, H, SRCCOPY
ReleaseDC 0, DC
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
ShowCursor True
End Sub
Private Sub Timer1_Timer()
StretchBlt Me.hdc, W - 1, H - 1, -W, -H, Me.hdc, 0, 0, W, H, SRCCOPY
Me.Refresh
End Sub
2009-9-26 16:21 回复
ww0034 0位粉丝 4楼
这个是关闭QQ的代码
(需要添加一个Command1.一个text1)
这个程序打包的时候,金山毒霸说是病毒
希望懂的帮我看一下
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_RESTORE = 9
Private Const SW_SHOW = 5
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPheaplist = &H1
Private Const TH32CS_SNAPthread = &H4
Private Const TH32CS_SNAPmodule = &H8
Private Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule
Private Const MAX_PATH As Integer = 260
Private Const PROCESS_TERMINATE = &H1
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Text1 = "想关点退出啊.怎么那么笨!"
Cancel = True
End Sub
Private Sub command1_Click()
Dim i As Long
Dim proc As PROCESSENTRY32
Dim snap As Long
Dim exename As String
Dim hand As Long, theloop As Long
snap = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) ':获得进程“快照”的句柄
proc.dwSize = Len(proc)
theloop = ProcessFirst(snap, proc) ':获取第一个进程,并得到其返回值
i = 0
While theloop 0 ':当返回值非零时继续获取下一个进程
exename = proc.szExeFile
If Left(LCase(exename), 6) = "qq.exe" Then
hand = OpenProcess(PROCESS_TERMINATE, True, proc.th32ProcessID) ':获取进程句柄
TerminateProcess hand, 0 ':关闭进程
End If
theloop = ProcessNext(snap, proc)
Wend
CloseHandle snap ':关闭进程“快照”句柄
MsgBox "真遗憾,您扣扣掉线了!"
End
End Sub
2009-9-26 16:22 回复
ww0034 0位粉丝 5楼
这个是爱不爱我代码,挺好玩的这个
(需要添加两个command)
Option Explicit
Private Sub Command1_GotFocus()
Command2.SetFocus
End Sub
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Randomize Timer
With Me
Command1.Move Rnd * (.ScaleWidth - Command1.Width), Rnd * (.ScaleHeight - Command1.Height)
End With
End Sub
Private Sub Command2_Click()
MsgBox "我也爱你!"
End
End Sub
Private Sub Form_Load()
Me.AutoRedraw = True
Me.FontSize = 30
Me.Print "你爱不爱我?"
Command1.Caption = "不爱"
Command2.Caption = "爱"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Cancel = 1
End Sub
2009-9-26 16:22 回复
ww0034 0位粉丝 6楼
应用软件
--------------------------------------------------
繁体简体转换
(需要添加4个Cammand.1个text)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Declare Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'简转繁
Public Function JToF(ByVal Str As String) As String
Dim STlen As Long
Dim STf As String
STlen = lstrlen(Str)
STf = Space(STlen)
LCMapString &H804, &H4000000, Str, STlen, STf, STlen
JToF = STf
End Function
'繁转简
Public Function FToJ(ByVal Str As String) As String
Dim STlen As Long
Dim STj As String
STlen = lstrlen(Str)
STj = Space(STlen)
LCMapString &H804, &H2000000, Str, STlen, STj, STlen
FToJ = STj
End Function
Private Sub Command1_Click()
Text1.Text = JToF(Text1.Text)
End Sub
Private Sub Command2_Click()
Text1.Text = FToJ(Text1.Text)
End Sub
Private Sub Command3_Click()
Text1.Text = ""
End Sub
Private Sub Command4_Click()
End
End Sub
--------------------------------------------------
打开我的电脑等
(需要添加5个Command)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
'我的文档
ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1
Case 1
'我的电脑
ShellExecute Me.hwnd, "open", "explorer", "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1
Case 2
'网上邻居
ShellExecute Me.hwnd, "open", "explorer", "::{208d2c60-3aea-1069-a2d7-08002b30309d}", vbNullString, 1
Case 3
'回收站
ShellExecute Me.hwnd, "open", "explorer", "::{645ff040-5081-101b-9f08-00aa002f954e}", vbNullString, 1
Case 4
'控制面板
ShellExecute Me.hwnd, "open", "explorer", "::{21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1
End Select