`
gas17gas
  • 浏览: 25548 次
最近访客 更多访客>>
社区版块
存档分类
最新评论

发几个vb整人小程序代码.第一次发帖.希望大家多多支持

 
阅读更多

发几个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
分享到:
评论

相关推荐

Global site tag (gtag.js) - Google Analytics