VB可视化窗体的趣味（让屏幕都动起来）

摘要：众所周知，VB是一种可视化的编程工具，可视化的编程工具总会让学习者更容易理解编程中的一些更为负责的东西。而编程又被一般人群望而却步，其实编程是一件非常有意思的事情。结合学生们的一些想法，想到了很久以前的一些恶作剧，废了一些力气写了下面的代码以提高编程初学者对编程的兴趣

文献标识码：A

文章编号：1671-864X（2015）03-0199-02

一、总体构想

将整个屏幕的图像复制到本程序的Form1窗口内，制造一个虚假的屏幕图像。

Form1 窗口会最大化并不断抖动，遮住其他任何程序窗口。由于本程序窗口最大化，四周的边界空白区为黑色，足以以假乱真，让用户相信这就是屏幕图像。然后告诉用户一个假消息：Windows 检测到你的显示器未放平，这种状态的时间已很长了，已导致显示器屏幕抖动，情况严重时会爆炸。

时间（默认30秒）未到前，用户无法使用开始菜单和任务管理器。时间到后，Form1 窗口缩小，允许用户结束本程序。

程序有2个窗体：Form1 和 Form2，Form1是启动窗体：

二、form1窗体

' ' Form1 窗体：

----------------------------------------------------------------

' 在 Form1 上放置控件：Timer1、Picture1

' 在属性窗口将 Form1 的 BorderStyle 属性设置为 0，其他控件及属性无需进行任何设置

' 以下是 Form1 代码

Dim ctT1 As Single

Public ctCi As Long, ctT As Single '

Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd 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 RasterOpConstants) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long

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()

ctT = 30 '指定时间（秒），时间到了后才允许退出程序。可根据自己喜好修改为更长的时间

Timer1.Enabled = True: Timer1.Interval = 100

Me.WindowState = 2 '最大化窗口

'Me.WindowState = 0 ''****调试代码，Form1 窗口最大化会导致调试困难，调试完毕应删除此语句

Me.BackColor = 0

Call CopyScreen

ctT1 = Timer

End Sub

Private Sub Form_Activate()

Static Ci As Long

If Ci = 0 Then Form2.Show 1

Ci = 1

End Sub

Private Sub Timer1_Timer()

Dim X As Single, Y As Single, S As Single

S = Timer - ctT1

Form2.Label2.Caption = "时间：" & Format(S, "0.0") & " 秒"

If S < ctT Then '----将窗口设置为最前面，阻止用户使用任务管理器等其他程序

Call WinInTop(Me.hWnd, True)

Else '------------到了指定时间（秒）后，允许退出程序

If Me.WindowState <> 0 Then

Me.WindowState = 0

Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height * 0.8

End If

Form2.Label1.ForeColor = 0

Form2.Label1.Caption = vbCrLf & vbCrLf & " 这是一个玩笑，你的显示器不会发生任何问题。" & vbCrLf & vbCrLf & vbCrLf & vbCrLf & " 单击“退出”结束本程序。"

Form2.Label2.Caption = "哈哈，一个玩笑"

Form2.Command1.Visible = False: Form2.Command2. Visible = True

End If

S = Screen.TwipsPerPixelX * 10 '抖动最大幅度：10 个像素

Randomize

X = (0.5 - Rnd) * S: Y = (0.5 - Rnd) * S

Picture1.Move X, Y

If Me.WindowState <> 2 Then Exit Sub '当 Form1 最大化时才让 Form2 也一起抖动

Form2.Move (Screen.Width - Form2.Width) * 0.5 + X, (Screen.Height - Form2.Height) * 0.5 + Y

End Sub

Private Sub CopyScreen()

'------复制整个屏幕到 Picture1

Dim dl As Long, nHwnd As Long, nWinDC As Long, nW As Long, nH As Long

nHwnd = 0

nWinDC = GetWindowDC(nHwnd) '屏幕设备场景句柄

nW = Screen.Width: nH = Screen.Height

Picture1.Move 0, 0, nW, nH

Picture1.AutoRedraw = True: Picture1.BorderStyle = 0

nW = nW /Screen.TwipsPerPixelX: nH = nH /Screen. TwipsPerPixelY

dl = BitBlt(Picture1.hdc, 0, 0, nW, nH, nWinDC, 0, 0, vbSrcCopy)

dl = ReleaseDC(nHwnd, nWinDC) '释放设备场景：成功返回为1，否则为0

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

三、 Form2 窗体

' 在 Form2 上放置控件：Command1、Command2、Label1、Label2

' 以下是 Form2 代码

Dim ctExit As Boolean

Private Sub Form_Load()

Dim S As Single

Me.Icon = LoadPicture(): Me.Caption = "Windows 警告"

Me.Move Screen.Width * 0.2, Screen.Height * 0.3, Screen.Width * 0.6, Screen.Height * 0.4

S = Me.TextHeight("A")

Command1.Caption = "确定(&Y)": Command2.Caption = "退出(&E)"

Command1.Move Me.ScaleWidth - S * 7, Me.ScaleHeight -S * 3, S * 6, S * 2

Command2.Move Command1.Left, Command1.Top, S * 6, S * 2

Label1.BackStyle = 0: Command2.Visible = False

Label1.Font.Size = 12: Label2.Font.Size = 12

Label1.Move S, S, Me.ScaleWidth - S * 2, Me.ScaleHeight

Label2.Move S, Command1.Top + Command1.Height * 0.2

Label2.AutoSize = True

Call Info End Sub

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

'不要用 Click 事件

Form1.ctCi = Form1.ctCi + 1

Call Info

End Sub

Private Sub Info()

Dim Str1 As String, nStr As String

Select Case Form1.ctCi

Case 0

Str1 = "警告！" & vbCrLf & vbCrLf

nStr = " Windows 检测到你的显示器未放平，这种

状态的时间已很长了，已导致显示器屏幕抖动，情况严重时会爆炸。"

Case 1

Label1.ForeColor = RGB(0, 0, 255)

Str1 = "再次警告！" & vbCrLf & vbCrLf

nStr = " 你的显示器仍然未放平，仍有爆炸的危险。"

Case 2

Label1.ForeColor = RGB(255, 0, 255)

Str1 = "再次再次警告！！" & vbCrLf & vbCrLf

nStr = " 请在显示器底座的右下面垫一张厚度为 2毫米的纸，不然有爆炸的危险。"

Case 3

Label1.ForeColor = RGB(255, 0, 0)

Str1 = "再次警告！！！" & vbCrLf & vbCrLf

nStr = " 右方太高！" & vbCrLf & vbCrLf & " 请在显示器底座的左下面垫一张厚度为 1 毫米的纸，不然有爆炸的危险。"

Case Else

Label1.ForeColor = RGB(255, 0, 0)

Str1 = "严重警告！！！！" & vbCrLf & vbCrLf nStr = " 显示器仍然未调整好。"

End Select

Label1.Caption = Str1 & nStr & vbCrLf & vbCrLf & "请在 " & Form1.ctT & " 秒钟内调整好显示器！显示器调整好后，请单击“确定”。"

End Sub

Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)'

结束程序：不要用 Click 事件

ctExit = True

Unload Me: Unload Form1

End Sub

Private Sub Form_Unload(Cancel As Integer)

If Not ctExit Then Cancel=1

End Sub