这个东西难度不大,调用了QQ自带的timwp.exe程序,实现起来就很容易了,下面是代码部分,建立一个模块:

Option Explicit
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Const WM_CLOSE = &H10

'注册表操作
Private Const HKEY_LOCAL_MACHINE = &H80000002
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
RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function
RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'-------------------------------------------------
Declare Function SendMessageA Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Declare Function
PostMessage Lib "user32" Alias "PostMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function
FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function
GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function
GetWindow Lib "user32" (ByVal Hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function
GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function
SendMessage Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const
GW_HWNDFIRST = 0 '第一个
Public Const GW_HWNDNEXT = 2 '下一个
Publi
c Const
DVASPECT_CONTENT = 1
Public Const WM_USER = &H400
Public Const EM_PASTESPECIAL = WM_USER + 64
Public Const CF_TEXT = 1
Const EM_REPLACESEL = &HC2
Const BM_CLICK = &HF5

Public Type QQWindowHwnd
WindowHwnd
As Long
TxtHwnd As Long
SendButtonHwnd As Long
CloseButtonHwnd As Long
End
Type

Public Type repastespecial
dwAspect
As Long
dwParam As Long
End
Type

Private QQpath As String
Public
QQExePath As String

Public Sub
main()
QQpath = getQqPath
If QQpath = "" Then
QQpath = InputBox("请填写QQ的安装路径", "QQ路径", "N")
End If
If
QQpath = "N" Then End
QQExePath = QQpath & "timwp.exe " + "Tencent://Message/?Menu=YES&Exe=&Uin="
FrmMain.Show
End Sub

Private Function
getQqPath() As String '获取QQ注册表路径
Dim ret, lenData, hKey As Long
Dim
sValue As String
Dim
name As String

sValue = Space(255)
Const REG_SZ = 1&

lenData =
255
name = "Install"
ret = 1
ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Tencent\QQ", hKey)
If ret = 0 Then '正确返回0,不正确返回错误编号
ret = RegQueryValueEx(hKey, name, 0, REG_SZ, ByVal sValue, lenData)
ret = InStr(
1, sValue, "QQ\")
getQqPath = Left(sValue, ret +
2)
End If
ret = RegCloseKey(hKey)
End Function

Public Function
FindQQ(ByVal Hwnd As Long) As Long
Dim
strName As String * 255
Dim className As String * 255
Dim Q_hwnd As Long
Q_hwnd = GetWindow(Hwnd, GW_HWNDFIRST)
Do While Q_hwnd <> 0
GetWindowText Q_hwnd, strName, 255
GetClassName Q_hwnd, className, 255
If ((InStr(strName, "聊天中") > 0) or (InStr(strName, "会话中") > 0)) And (InStr(className, "#32770") > 0) Then
FindQQ = Q_hwnd
Exit Function
End If
Q_hwnd = GetWindow(Q_hwnd, GW_HWNDNEXT)
Loop
End Function

Public Function
getQQHwnd(ByVal Hwnd As Long) As QQWindowHwnd
Dim tmphwnd As Long
getQQHwnd.WindowHwnd = FindWindowEx(Hwnd, 0, "#32770", vbNullString)
tmphwnd = FindWindowEx(getQQHwnd.WindowHwnd,
0, "Afxwnd42", vbNullString)
tmphwnd = FindWindowEx(getQQHwnd.WindowHwnd, tmphwnd,
"afxwnd42", "")
getQQHwnd.TxtHwnd = FindWindowEx(tmphwnd,
0, "richedit20A", vbNullString)
getQQHwnd.SendButtonHwnd = FindWindowEx(getQQHwnd.WindowHwnd,
0, "button", "发送(&S)")
getQQHwnd.CloseButtonHwnd = FindWindowEx(getQQHwnd.WindowHwnd,
0 ="#000000">, "button", "关闭(&C)")
End Function

Public Sub
SendQQMessage(ByRef QQhwnd As QQWindowHwnd, ByVal sTText As String)
SendMessageA QQhwnd.TxtHwnd, EM_REPLACESEL,
0, ByVal sTText
SendMessageA QQhwnd.SendButtonHwnd, BM_CLICK,
0, ByVal 0
SendMessageA QQhwnd.CloseButtonHwnd, BM_CLICK, 0, ByVal 0
End Sub


再建立一个窗体,窗体上放2个文本框,text1和text2,再放一个按钮,text1用于填写QQ号码,text2用于填写想要发送的内容

Option Explicit
Private delayNum As Long

Private Sub
Command1_Click()
Shell QQExePath & Text1.Text
Call delay(10)
Dim QQhwnd As Long
QQhwnd = FindQQ(Me.Hwnd)
Dim x As QQWindowHwnd
x = ModConst.getQQHwnd(QQhwnd)
SendQQMessage x, Text2.Text
End Sub

Private Sub
delay(ByVal sTime As Long)
delayNum = sTime
Timer1.Enabled =
True
Do
DoEvents
Loop While Timer1.Enabled = True
End Sub

Private Sub
Timer1_Timer()
Static I As Integer
I = I + 1
If I > delayNum Then
I = 0
Timer1.Enabled = False
End If
End Sub


好了,运行试试

 
目前有0条回应
Comment
Trackback
你目前的身份是游客,请输入昵称和电邮!