VB

VB蓝屏代码-超邪恶

Jonty
2013-11-30 / 9 评论 / 80 阅读 / 正在检测是否收录...

添加一个timer如图

代码:

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

Private Sub Form_Load()
    ctExitT = 12 '程序自动退出的时间(秒),可根据自己的喜好设定
    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: ctExitT = ctExitT - 1: ctT = ctT + 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 "请等待 " &amp; ctExitT &amp; " 秒……"
      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 = &amp;H1     'wFlags 参数
    Const SWP_NoMove = &amp;H2
    Const SWP_NoZorder = &amp;H4
    Const SWP_ShowWindow = &amp;H40
    Const SWP_HideWindow = &amp;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
本文共 179 个字数,平均阅读时长 ≈ 1分钟
0

打赏

海报

正在生成.....

评论 (9)

取消
  1. 头像
    祥磊部落 Lv.1
    日本 ·Windows XP · Google Chrome
    沙发

    对于基础不错

    回复 删除 垃圾
    1. 头像
      gkroot Lv.6
      中国山东省 ·iPhone · Google Chrome
      @ 祥磊部落

      嗯~

      回复 删除 垃圾
  2. 头像
    Soar、毅 Lv.3
    中国北京市丰台区 ·Windows 7 · Google Chrome
    板凳

    好神奇的VB6.0~

    回复 删除 垃圾
    1. 头像
      gkroot Lv.6
      中国山东省 ·iPhone · Google Chrome
      @ Soar、毅

      。。你是在鄙视我吗。

      回复 删除 垃圾
  3. 头像
    gqdsc Lv.1
    中国湖南省 ·Windows X64 · MicroSoft Edge
    地毯

    可以用C+A+d终极杀手,所以最好还是加入屏蔽所有快捷键的功能,就完美了~

    回复 删除 垃圾
    1. 头像
      gkroot Lv.6
      ·iPhone · Google Chrome
      @ gqdsc

      好想法~

      回复 删除 垃圾
  4. 头像
    Pang Lv.1
    ·Windows 7 · Google Chrome
    第4楼

    定期死机 哈哈

    回复 删除 垃圾
  5. 头像
    just Lv.1
    ·Windows 7 · Google Chrome
    第5楼

    ..路过,觉得随便弄个错误他就蓝了。。比如强杀系统进程,卸载系统驱动。。太多了

    回复 删除 垃圾
    1. 头像
      gkroot Lv.6
      ·iPhone · UC Browser
      @ just

      @just 这个无副作用。。

      回复 删除 垃圾