风一样的男孩 发表于 2011-10-31 13:02:10

整人VB小程序：蓝屏死机

'''以下是窗体代码，在 VB6.0 上调试通过：
'   一、在窗体添加一个定时器控件：Timer1，不必设置任何属性，采用默认属性即可
'   二、在属性窗口将窗体的 BorderStyle 属性设置为 0


Dim ctCi As Long, ctT As Long, ctExitT As Long, ctStr() As String, ctStrS As Long, ctExit


As Boolean
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal


hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As


Long, ByVal wFlags As Long) As Long
Dim ctShowT As Long


Private Sub Form_Load()
    ctShowT = 10    '**** 运行程序后，延时显示蓝屏的时间（秒），可根据自己的喜好设定
   ctExitT = 120   '**** 程序自动退出的时间（秒），可根据自己的喜好设定
   Me.Hide
    Me.BackColor = RGB(0, 0, 255): Me.Caption = "蓝屏死机"
    Me.AutoRedraw = True: Me.WindowState = 2
    Me.Font.Size = 21: Me.ForeColor = &HFFFFFF
    Timer1.Interval = 50: Timer1.Enabled = True
    ReDim ctStr(0 To 0)
End Sub


Private Sub Form_Click()
    If ctExit Then Unload Me
End Sub


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'单击左上角 20 个像素范围
    Dim S1 As Single
    S1 = Me.ScaleX(20, 3, Me.ScaleMode)
    If X > S1 Or Y > S1 Then ctCi = 0: Exit Sub
    ctCi = ctCi + 1
    If ctCi > 4 Then Call ExitInf
End Sub


Private Sub ExitInf()
    Timer1.Enabled = False: Me.WindowState = 0: ctCi = 0: ctExit = True
    Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height *


0.8
    ctStrS = -1
    AddStr "哈哈，一个玩笑"
    AddStr "结束本程序：单击蓝色区任意位置"
    Call ShowStr
End Sub


Private Sub Timer1_Timer()
   Static Ci As Long
   WinInTop Me.hWnd, True '始终将窗体保持在最前面，使用户无法使用开始菜单、任务管理器，无


法操作任何程序
Ci = Ci + 1
If Ci * Timer1.Interval < 1000 Then Exit Sub '保证一秒钟计数一次
Ci = 0

If ctShowT > 1 Then ctShowT = ctShowT - 1: Exit Sub
If ctShowT = 1 Then ctShowT = 0: Me.Show

ctT = ctT + 1: ctExitT = ctExitT - 1
If ctExitT < 1 Then Call ExitInf: Exit Sub

Select Case ctT
   Case 1
      ctStrS = -1
      AddStr "Your Windows is died"
      Call ShowStr
   Case 5
      ctStrS = -1
      AddStr "Windows 警告"
      AddStr "内存出现严重错误"
      Call ShowStr
   Case 10 To 24
      ctStrS = -1
      AddStr "警告"
      AddStr "硬盘错误，无法正常运行 Windows"
      AddStr "Windows 正在试图修复所有错误"
      AddStr "请等待 " & ctExitT & " 秒……"
      Call ShowStr
   Case 25
      ctStrS = -1
      AddStr "警告"
      AddStr "由于你使用了盗版操作系统"
      AddStr "微软惩罚你：定期死机"
      Call ShowStr
   Case Else
      If ctT > 30 Then ctT = 0
   End Select
End Sub


Private Sub AddStr(nStr)
    ctStrS = ctStrS + 1
    ReDim Preserve ctStr(0 To ctStrS): ctStr(ctStrS) = nStr
End Sub


Private Sub ShowStr()
    Dim I As Long, S1 As Single, Y0 As Single, Y As Single, Hj As Single
    S1 = Me.TextHeight("A"): Hj = 0.5 '行高和行距
    Y0 = S1 * (1 + Hj) * (1 + ctStrS) - S1 * Hj
    Y0 = (Me.ScaleHeight - Y0) * 0.5
    Me.Cls
    For I = 0 To ctStrS
      Me.CurrentX = (Me.ScaleWidth - Me.TextWidth(ctStr(I))) * 0.5
      Me.CurrentY = Y0 + I * S1 * (1 + Hj)
      Me.Print ctStr(I)
    Next
End Sub


Private Sub WinInTop(nWnd As Long, Optional InTop As Boolean)
    Const HWND_NoTopMost = -2 '取消在最前
    Const HWND_TopMost = -1    '最上
    Const SWP_NoSize = &H1   'wFlags 参数
    Const SWP_NoMove = &H2
    Const SWP_NoZorder = &H4
    Const SWP_ShowWindow = &H40
    Const SWP_HideWindow = &H80
    Dim nIn As Long
    If InTop Then nIn = HWND_TopMost Else nIn = HWND_NoTopMost
    SetWindowPos nWnd, nIn, 0, 0, 0, 0, SWP_NoSize + SWP_NoMove
End Sub


点滴滴 发表于 2011-10-31 22:38:37

看不懂的 东西

xuxptop 发表于 2011-11-2 02:48:22

无聊的东西

潶铯僸葯 发表于 2011-11-3 10:04:37

不错啊！我手下

nx2008 发表于 2011-11-21 11:36:46

崩溃了····你还认活不？这么长的代码   还用防复制，要命呢

liping1995 发表于 2011-11-26 18:38:13

汗 什么 东西 呵呵

wenbing5241 发表于 2011-12-22 15:55:35

zmxzy2001 发表于 2012-2-12 20:33:39

balang 发表于 2012-4-14 20:16:28

整人啊

qwzsfre 发表于 2013-3-30 22:58:44

挺恶搞的，不知道怎么做，能发个软件出来吗？
页: [1]
查看完整版本: 整人VB小程序：蓝屏死机