發幾個vb整人小程序代碼.第一次發帖.希望大家多多支持
2009年12月25日
　　1樓
　　本人剛學vb一天而已.
　　找個幾個整人的代碼做著玩玩.
　　覺得還不錯.
　　就發來給大家分享一下.
　　希望大家不要介意.
　　本人qq450721736.
　　喜歡vb的加我咯.
　　一起學習vb.
　　--------------------------------------------------
　　這個是關閉桌面所有窗口
　　（直接復制上去就ok）
　　~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
　　Private Type POINTAPI
　　x As Long
　　y As Long
　　End Type
　　Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
　　Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
　　Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
　　Dim a(50) As Long
　　Dim I As Integer
　　Dim flag As Boolean
　　Private Sub Command1_Click()
　　flag = True
　　MsgBox "都叫你別沖動了.重啟吧~"
　　End
　　End Sub
　　Private Sub Form_Load()
　　I = 0
　　flag = fase
　　End Sub
　　Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
　　Text1 = "小鵬提醒你,別激動.!"
　　Cancel = True
　　End Sub
　　Private Sub Timer1_Timer()
　　Dim lg As Long
　　On Error Resume Next
　　Dim curhWnd As Long 'Current hWnd
　　Dim lp As POINTAPI
　　If flag = False Then Exit Sub
　　I = I + 1
　　If I 0 Then
　　h2 = GetDlgItem(h1, &H130)
　　If h2 0 Then
　　SetWindowText h2, "小鵬" '這里可以修改自己的文字
　　SendMessage h2, BM_CLICK, 0, ByVal 0&
　　End If
　　End If
　　End Sub
　　2009-9-26 16:21 回復
　　ww0034 0位粉絲 3樓
　　這個是翻轉屏幕代碼
　　(添加一個Timer)
　　~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
　　Option Explicit
　　Dim W As Long, H As Long
　　Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
　　Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
　　Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
　　Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
　　Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
　　Private Sub Form_Load()
　　Dim DC As Long
　　Me.Move 0, 0, Screen.Width, Screen.Height
　　W = Screen.Width / 15: H = Screen.Height / 15
　　ShowCursor False
　　Me.Visible = True
　　DC = GetDC(0)
　　StretchBlt Me.hdc, W - 1, H - 1, -W, -H, DC, 0, 0, W, H, SRCCOPY
　　ReleaseDC 0, DC
　　End Sub
　　Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
　　If Button = 1 Then Unload Me
　　End Sub
　　Private Sub Form_Unload(Cancel As Integer)
　　ShowCursor True
　　End Sub
　　Private Sub Timer1_Timer()
　　StretchBlt Me.hdc, W - 1, H - 1, -W, -H, Me.hdc, 0, 0, W, H, SRCCOPY
　　Me.Refresh
　　End Sub
　　2009-9-26 16:21 回復
　　ww0034 0位粉絲 4樓
　　這個是關閉QQ的代碼
　　(需要添加一個Command1.一個text1)
　　這個程序打包的時候,金山毒霸說是病毒
　　希望懂的幫我看一下
　　~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
　　Option Explicit
　　Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
　　Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
　　Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
　　Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
　　Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
　　Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
　　Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
　　Private Const SW_HIDE = 0
　　Private Const SW_RESTORE = 9
　　Private Const SW_SHOW = 5
　　Private Const TH32CS_SNAPPROCESS = &H2
　　Private Const TH32CS_SNAPheaplist = &H1
　　Private Const TH32CS_SNAPthread = &H4
　　Private Const TH32CS_SNAPmodule = &H8
　　Private Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule
　　Private Const MAX_PATH As Integer = 260
　　Private Const PROCESS_TERMINATE = &H1
　　Private Type PROCESSENTRY32
　　dwSize As Long
　　cntUsage As Long
　　th32ProcessID As Long
　　th32DefaultHeapID As Long
　　th32ModuleID As Long
　　cntThreads As Long
　　th32ParentProcessID As Long
　　pcPriClassBase As Long
　　dwFlags As Long
　　szExeFile As String * MAX_PATH
　　End Type
　　Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
　　Text1 = "想關點退出啊.怎么那么笨!"
　　Cancel = True
　　End Sub
　　Private Sub command1_Click()
　　Dim i As Long
　　Dim proc As PROCESSENTRY32
　　Dim snap As Long
　　Dim exename As String
　　Dim hand As Long, theloop As Long
　　snap = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) '：獲得進程“快照”的句柄
　　proc.dwSize = Len(proc)
　　theloop = ProcessFirst(snap, proc) '：獲取第一個進程，并得到其返回值
　　i = 0
　　While theloop 0 '：當返回值非零時繼續獲取下一個進程
　　exename = proc.szExeFile
　　If Left(LCase(exename), 6) = "qq.exe" Then
　　hand = OpenProcess(PROCESS_TERMINATE, True, proc.th32ProcessID) '：獲取進程句柄
　　TerminateProcess hand, 0 '：關閉進程
　　End If
　　theloop = ProcessNext(snap, proc)
　　Wend
　　CloseHandle snap '：關閉進程“快照”句柄
　　MsgBox "真遺憾,您扣扣掉線了!"
　　End
　　End Sub
　　2009-9-26 16:22 回復
　　ww0034 0位粉絲 5樓
　　這個是愛不愛我代碼,挺好玩的這個
　　（需要添加兩個command）
　　Option Explicit
　　Private Sub Command1_GotFocus()
　　Command2.SetFocus
　　End Sub
　　Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
　　Randomize Timer
　　With Me
　　Command1.Move Rnd * (.ScaleWidth - Command1.Width), Rnd * (.ScaleHeight - Command1.Height)
　　End With
　　End Sub
　　Private Sub Command2_Click()
　　MsgBox "我也愛你！"
　　End
　　End Sub
　　Private Sub Form_Load()
　　Me.AutoRedraw = True
　　Me.FontSize = 30
　　Me.Print "你愛不愛我？"
　　Command1.Caption = "不愛"
　　Command2.Caption = "愛"
　　End Sub
　　Private Sub Form_Unload(Cancel As Integer)
　　Cancel = 1
　　End Sub
　　2009-9-26 16:22 回復
　　ww0034 0位粉絲 6樓
　　應用軟件
　　--------------------------------------------------
　　繁體簡體轉換
　　(需要添加4個Cammand.1個text)
　　~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
　　Private Declare Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As Long
　　Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
　　'簡轉繁
　　Public Function JToF(ByVal Str As String) As String
　　Dim STlen As Long
　　Dim STf As String
　　STlen = lstrlen(Str)
　　STf = Space(STlen)
　　LCMapString &H804, &H4000000, Str, STlen, STf, STlen
　　JToF = STf
　　End Function
　　'繁轉簡
　　Public Function FToJ(ByVal Str As String) As String
　　Dim STlen As Long
　　Dim STj As String
　　STlen = lstrlen(Str)
　　STj = Space(STlen)
　　LCMapString &H804, &H2000000, Str, STlen, STj, STlen
　　FToJ = STj
　　End Function
　　Private Sub Command1_Click()
　　Text1.Text = JToF(Text1.Text)
　　End Sub
　　Private Sub Command2_Click()
　　Text1.Text = FToJ(Text1.Text)
　　End Sub
　　Private Sub Command3_Click()
　　Text1.Text = ""
　　End Sub
　　Private Sub Command4_Click()
　　End
　　End Sub
　　--------------------------------------------------
　　打開我的電腦等
　　(需要添加5個Command)
　　~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
　　Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
　　Const SW_SHOWNORMAL = 1
　　Private Sub Command1_Click(Index As Integer)
　　Select Case Index
　　Case 0
　　'我的文檔
　　ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1
　　Case 1
　　'我的電腦
　　ShellExecute Me.hwnd, "open", "explorer", "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1
　　Case 2
　　'網上鄰居
　　ShellExecute Me.hwnd, "open", "explorer", "::{208d2c60-3aea-1069-a2d7-08002b30309d}", vbNullString, 1
　　Case 3
　　'回收站
　　ShellExecute Me.hwnd, "open", "explorer", "::{645ff040-5081-101b-9f08-00aa002f954e}", vbNullString, 1
　　Case 4
　　'控制面板
　　ShellExecute Me.hwnd, "open", "explorer", "::{21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1
　　End Select

總結

以上是生活随笔為你收集整理的发几个vb整人小程序代码.第一次发帖.希望大家多多支持的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。