|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 LeverHz 于 2019-9-21 20:40 编辑
EXCEL控制PC微信给手机微信收发文本信息的接口。调试了好几天，在WIN10、office2019上测试通过。
大家若觉得好用，点个赞。
' 用于ms级占用CPU延时
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
' 控制鼠标
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
' 延时设置
Public Const DRV_MAX_DELAY_MS As Long = 60000 ' 最大延时1分钟
Public Const CELL_WC_MSG_BUF As String = "B32"
Public Const WC_MSG_TGT As String = "ABC" '微信窗口名称，一般为好友的昵称
'********************************************************************
' 将文本拷贝到剪切板中
'********************************************************************
Private Function DRV_CopyText2Clipboard(vText As String)
Dim MSForms_DataObject As Object
Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '创建剪切板对象
MSForms_DataObject.SetText vText
MSForms_DataObject.PutInClipboard
Set MSForms_DataObject = Nothing
DRV_CopyText2Clipboard = ""
End Function
'********************************************************************
' 从剪切板中获取文本
'********************************************************************
Private Function DRV_GetTextFromClipboard() As String
Dim vMsg As String
Dim MSForms_DataObject As Object
Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '创建剪切板对象
MSForms_DataObject.GetFromClipboard
DRV_GetTextFromClipboard = MSForms_DataObject.GetText
Set MSForms_DataObject = Nothing
End Function
Sub TEST_GetTextFromClipboard()
Debug.Print DRV_GetTextFromClipboard()
End Sub
'********************************************************************
' 清空剪切板
'********************************************************************
Private Function DRV_ClearClipboard()
' Sheets(SHT_NAME_CONFIG).Activate
' Range(CELL_WC_MSG_BUF).Clear
' Range(CELL_WC_MSG_BUF).Select
Dim vMsg As String
vMsg = ""
DRV_CopyText2Clipboard vMsg
DRV_ClearClipboard = ""
End Function
'********************************************************************
' 增加时间戳和前后缀
'********************************************************************
Private Function DRV_MsgAddPrefix(vText As String) As String
Dim vRet As String
vRet = "#** " & Now() & Chr(10) & vText & Chr(10) & "**#"
' vRet = "#** " & Now() & Chr(10) & vText & Chr(10) & "**#" & Chr(10)
DRV_MsgAddPrefix = vRet
End Function
Sub TEST_CopySelection2Clipboard()
DRV_CopyText2Clipboard DRV_MsgAddPrefix(Selection.Text)
End Sub
'********************************************************************
' 使用微信发发送信息
' vTargetWindowName As String 目标窗口名称
' vMsgCell As String 要发送的信息文本，本函数会追加前后缀
'********************************************************************
Private Function DRV_SendWCMsg(vTargetWindowName As String, vMsg As String)
Dim vSht As Worksheet
Dim vName As String
vName = ActiveSheet.Name
Sheets(SHT_NAME_CONFIG).Activate
Range(CELL_WC_MSG_BUF).Value = vMsg
Range(CELL_WC_MSG_BUF).Select
DRV_CopyText2Clipboard DRV_MsgAddPrefix(Selection.Text)
Dim oWS
Set oWS = CreateObject("Wscript.shell")
oWS.AppActivate vTargetWindowName
DRV_MsDelay 500
SendKeys "^V"
DRV_MsDelay 100
SendKeys "~~"
DRV_MsDelay 100
Sheets(vName).Activate
DRV_SendWCMsg = ""
End Function
Sub TEST_SendSelection2WC()
Call DRV_SendWCMsg(WC_MSG_TGT, Selection.Text)
End Sub
'********************************************************************
' 模拟鼠标操作，sleep函数不好用
'********************************************************************
Private Function DRV_GetWCMsgOperateKM()
'移动到最新一条消息上面，右键调出复制窗口
SetCursorPos 2100, 1220
DRV_MsDelay (100)
mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
DRV_MsDelay (100)
'移动到复制按钮上，左键点击复制
SetCursorPos 2120, 1240
DRV_MsDelay (100)
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
DRV_MsDelay (100)
'移动到发送消息窗口处，恢复环境
SetCursorPos 2120, 1340
DRV_MsDelay (100)
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
DRV_MsDelay (100)
End Function
'********************************************************************
' 接收微信发送过来的消息
' 预置条件: 打开微信窗口，将目标微信窗口挪到右下角. 让收到的第一条消息正好处于预设的位置
' 限制较大，后续需要考虑替代
' TODO: 考虑出现屏保，显示器关闭的情况
'********************************************************************
Private Function DRV_GetWCMsg() As String
Call DRV_ClearClipboard
Call DRV_GetWCMsgOperateKM
DRV_GetWCMsg = DRV_GetTextFromClipboard()
End Function
' 获取微信消息，并回应一条消息
Sub TEST_GetWCMsg()
Dim vMsg As String
vMsg = DRV_GetWCMsg()
If "" = vMsg Then
vMsg = Now() & " Get Nothing from WX"
Else
vMsg = Now() & " Get Msg from WX: " & Chr(10) & vMsg
End If
Debug.Print vMsg
DRV_SendWCMsg WC_MSG_TGT, vMsg
End Sub
'更好的办法是使用timeGetTime函数，timeGetTime函数返回的是开机到现在的毫秒数，可以支持1毫秒的间隔时间，而且永远增加，不存在回头的问题。
'当然不是永远不回头，毕竟Long型变量（双字，4字节）也是有取值范围的，这个值在0到2^32之间。大约49.71天。
'********************************************************************
' MS级延时.
'********************************************************************
Private Function DRV_MsDelay(vDelay As Long)
Dim vTimeStart As Long
vTimeStart = timeGetTime
If vDelay > DRV_MAX_DELAY_MS Then
vDelay = DRV_MAX_DELAY_MS
End If
Do
DoEvents
Loop While timeGetTime - vTimeStart < vDelay
End Function
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-9-19 23:42
楼主
