VB可視化窗體的趣味（讓屏幕都動起來）

摘要：眾所周知，VB是一種可視化的編程工具，可視化的編程工具總會讓學(xué)習(xí)者更容易理解編程中的一些更為負責(zé)的東西。而編程又被一般人群望而卻步，其實編程是一件非常有意思的事情。結(jié)合學(xué)生們的一些想法，想到了很久以前的一些惡作劇，廢了一些力氣寫了下面的代碼以提高編程初學(xué)者對編程的興趣

文獻標(biāo)識碼：A

文章編號：1671-864X（2015）03-0199-02

一、總體構(gòu)想

將整個屏幕的圖像復(fù)制到本程序的Form1窗口內(nèi)，制造一個虛假的屏幕圖像。

Form1 窗口會最大化并不斷抖動，遮住其他任何程序窗口。由于本程序窗口最大化，四周的邊界空白區(qū)為黑色，足以以假亂真，讓用戶相信這就是屏幕圖像。然后告訴用戶一個假消息：Windows 檢測到你的顯示器未放平，這種狀態(tài)的時間已很長了，已導(dǎo)致顯示器屏幕抖動，情況嚴(yán)重時會爆炸。

時間（默認(rèn)30秒）未到前，用戶無法使用開始菜單和任務(wù)管理器。時間到后，F(xiàn)orm1 窗口縮小，允許用戶結(jié)束本程序。

程序有2個窗體：Form1 和 Form2，F(xiàn)orm1是啟動窗體：

二、form1窗體

' ' Form1 窗體：

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

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

' 在屬性窗口將 Form1 的 BorderStyle 屬性設(shè)置為 0，其他控件及屬性無需進行任何設(shè)置

' 以下是 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 '指定時間（秒），時間到了后才允許退出程序?？筛鶕?jù)自己喜好修改為更長的時間

Timer1.Enabled = True: Timer1.Interval = 100

Me.WindowState = 2 '最大化窗口

'Me.WindowState = 0 ''****調(diào)試代碼，F(xiàn)orm1 窗口最大化會導(dǎo)致調(diào)試?yán)щy，調(diào)試完畢應(yīng)刪除此語句

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 '----將窗口設(shè)置為最前面，阻止用戶使用任務(wù)管理器等其他程序

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 & " 這是一個玩笑，你的顯示器不會發(fā)生任何問題。" & vbCrLf & vbCrLf & vbCrLf & vbCrLf & " 單擊“退出”結(jié)束本程序。"

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 '當(dāng) Form1 最大化時才讓 Form2 也一起抖動

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

End Sub

Private Sub CopyScreen()

'------復(fù)制整個屏幕到 Picture1

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

nHwnd = 0

nWinDC = GetWindowDC(nHwnd) '屏幕設(shè)備場景句柄

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) '釋放設(shè)備場景：成功返回為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 參數(shù)

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 檢測到你的顯示器未放平，這種

狀態(tài)的時間已很長了，已導(dǎo)致顯示器屏幕抖動，情況嚴(yán)重時會爆炸。"

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 = "嚴(yán)重警告?。。?！" & vbCrLf & vbCrLf nStr = " 顯示器仍然未調(diào)整好。"

End Select

Label1.Caption = Str1 & nStr & vbCrLf & vbCrLf & "請在 " & Form1.ctT & " 秒鐘內(nèi)調(diào)整好顯示器！顯示器調(diào)整好后，請單擊“確定”。"

End Sub

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

結(jié)束程序：不要用 Click 事件

ctExit = True

Unload Me: Unload Form1

End Sub

Private Sub Form_Unload(Cancel As Integer)

If Not ctExit Then Cancel=1

End Sub