等待时间函数

#If VBA7 And Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#End If

发送QQ消息

Sub QQsendtxt(ByVal msg As Variant)
    Dim WshShell, lngCnt, strMsg
    strMsg = Join(msg, vbCrLf & "    ")
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.Run """C:\Program Files (x86)\Tencent\QQ\Bin\QQScLauncher.exe"" /uin:******** /quicklunch:291EB8ACA6BE6147814429F6A1A99E8AD98D131B0CA6087D19703442F93E275E6E5AB2BBE06F44A0"
    WshShell.Run "mshta vbscript:clipboardData.SetData(" + """" + "text" + """" + "," + """" & strMsg & """" + ")(close)", 0, True
    WshShell.SendKeys "^v"
    WshShell.SendKeys "{ENTER}"

    WshShell.Run """C:\Program Files (x86)\Tencent\QQ\Bin\QQScLauncher.exe"" /uin:********* /quicklunch:405659A24780696FD85C992D9512A550A08B07A5D21FEFEB24B47580AFD195E162DECFDA3926EB45"
    WshShell.Run "mshta vbscript:clipboardData.SetData(" + """" + "text" + """" + "," + """" & strMsg & """" + ")(close)", 0, True
    WshShell.SendKeys "^v"
    WshShell.SendKeys "{ENTER}"
   
    WshShell.SendKeys "%{F4}"
End Sub

发送微信消息

Sub SendTxt()
   Dim ws2 As Object, ws As Object
   Dim name As String, msg As String
   
    Set ws2 = CreateObject("wscript.shell")
    ws2.AppActivate "微信"
    ws2.SendKeys "^%w"
    Set ws2 = Nothing
  
    name = "*****"
    msg = "测试代码发送微信消息中"

    Set ws = CreateObject("wscript.shell")
    ws.Run "mshta vbscript:ClipboardData.SetData(" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & name & Chr(34) & ")(close)", 0, True
    Sleep 999
    ws.SendKeys "^f"
    Sleep 999
    ws.SendKeys "^v"
    Sleep 999
    ws.SendKeys "{ENTER}"
    Sleep 555
    ws.SendKeys "{TAB}"
    Sleep 555
    ws.Run "mshta vbscript:ClipboardData.SetData(" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & msg & Chr(34) & ")(close)", 0, True
    Sleep 500
    ws.SendKeys "^v"
    Sleep 300
    ws.SendKeys "{ENTER}"
    ws.SendKeys "%{F4}"
    Set ws = Nothing
End Sub

'强制结束vbs运行

Sub 结束VBS()

    Set ws = CreateObject("wscript.shell")
    ws.Run "taskkill /IM wscript.exe /F"

End Sub

关键的精彩在这里应用呢

'检测指定进程是否运行

  Public Function CheckApplicationIsRun(ByVal szExeFileName As String) As Boolean
        On Error GoTo Err
        Dim WMI
        Dim Obj
        Dim Objs
        CheckApplicationIsRun = False
        WMI = GetObject("WinMgmts:")
        Objs = WMI.InstancesOf("Win32_Process")
        For Each Obj In Objs
            If InStr(UCase(szExeFileName), UCase(Obj.Description)) <> 0 Then
                CheckApplicationIsRun = True
                If Not Objs Is Nothing Then Objs = Nothing
                If Not WMI Is Nothing Then WMI = Nothing
                Exit Function
            End If
        Next
        If Not Objs Is Nothing Then Objs = Nothing
        If Not WMI Is Nothing Then WMI = Nothing
        Exit Function
Err:
        If Not Objs Is Nothing Then Objs = Nothing
        If Not WMI Is Nothing Then WMI = Nothing
    End Function

QQ消息发送，*号表示QQ号

 Public Sub QQsendtxt(ByVal strMsg As String)
        Dim WSHShell
        Dim Pfile As String = "C:\Program Files (x86)\Tencent\QQ\Bin\QQ.exe"
        Dim qq As String = """C:\Program Files (x86)\Tencent\QQ\Bin\QQScLauncher.exe"" /uin:******** /quicklunch:291EB8ACA6BE6147814429F6A1A99E8AD98D131B0CA6087D19703442F93E275E6E5AB2BBE06F44A0"
        Dim mypath As String = Application.StartupPath & "\QQRun.txt"
        Try
            If IO.File.Exists(mypath) = False Then '判断文件是否存在
                IO.File.WriteAllText(mypath, Pfile & vbCrLf & qq)
            End If
            Dim txt As String = IO.File.ReadAllText(mypath)
            Dim arr() As String = Split(txt, vbCrLf)
            If UBound(arr) < 1 Then Exit Sub
            WSHShell = CreateObject("WScript.Shell")
            If CheckApplicationIsRun(arr(0).ToString) = False Then
                MsgBox("QQ程序没有打开，或路径不正确！请设置正的路径，并且设置QQ程序为自动运行登陆。")
                Exit Sub
            Else
                For i = 1 To UBound(arr)
                    WSHShell.Run(arr(i).ToString)
                    WSHShell.Run("mshta vbscript:clipboardData.SetData(" + """" + "text" + """" + "," + """" & strMsg & """" + ")(close)", 0, True)
                    WSHShell.SendKeys("^v")
                    WSHShell.SendKeys("{ENTER}")
                Next
                WSHShell.SendKeys("%{F4}")
            End If
        Catch ex As Exception
            MessageBox.Show(ex.Message)
        End Try

    End Sub

定时运行的代码

 'Public Sub StartTimer()
    '    Dim tcb As New TimerCallback(AddressOf TimerMethod)
    '    Dim objTimer As Timer
    '    objTimer = New Timer(tcb, Nothing, TimeSpan.FromSeconds(5), TimeSpan.FromSeconds(360 * 4))
    'End Sub
    'Public Sub TimerMethod(ByVal state As Object)
    '    'MsgBox("The Timer invoked this method.")
    '    实时统计()
    'End Sub

Public Sub 实时统计()
    Try
        dim txt as string="你好啊"
      
        QQsendtxt(txt)

    Catch ex As Exception
        MessageBox.Show(ex.Message)
    End Try
End Sub

欢迎指正，初出江湖露洞百出