EXCEL VBA"调用"微信发送文件

思路与之前发送信息一样，将“文件”放入剪贴板中，就可以用CTRL+V，粘贴到微信信息框中实现发送文件了。

可是VBA 自带函数FileCopy 并不产生文件复制到剪贴板的效果，需调用Window API接口操作，代码如下。（来自EXCEL HOME论坛）

Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatW" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal flags As Long, ByVal Size As Long) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As LongPtr, ByVal hpvSource As LongPtr, ByVal cbCopy As Long)
'   API函数定义结束
Private Const CF_HDROP As Long = 15&
Private Const DROPEFFECT_COPY As Long = 1
Private Const DROPEFFECT_MOVE As Long = 2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_DDESHARE As Long = &H2000
'  结构定义开始
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Type dropFiles
  pFiles As Long
  pt As POINTAPI
  fNC As Long
  fWide As Long
End Type
'  结构定义结束
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

上面的代码都是 API函数的定义所需的（64位的VBE环境）。下面代码是将文件复制到剪贴板。

 Sub clipCopyFile(FileList As Variant)
      Dim uDropEffect As Long, I As Long
      Dim dropFiles   As dropFiles
      Dim uGblLen     As Long, uDropFilesLen  As Long
      Dim hGblFiles   As LongPtr
      Dim hGblEffect  As LongPtr
      Dim mPtr        As LongPtr
      Dim FName   As String
      
      If OpenClipboard(0) Then
        EmptyClipboard
        FName = Trim(FileList)
        If Len(FName) Then
          uDropEffect = RegisterClipboardFormat(StrPtr("Preferred DropEffect"))
          hGblEffect = GlobalAlloc(GMEM_ZEROINIT Or GMEM_MOVEABLE Or GMEM_DDESHARE, Len(uDropEffect))
          mPtr = GlobalLock(hGblEffect)
          I = DROPEFFECT_COPY
          CopyMemory mPtr, VarPtr(I), Len(I)
          GlobalUnlock hGblEffect
          SetClipboardData uDropEffect, hGblEffect
          uDropFilesLen = LenB(dropFiles)
          With dropFiles
            .pFiles = uDropFilesLen
            .fWide = CLng(True)
          End With
          uGblLen = uDropFilesLen + LenB(FName) + 8
          hGblFiles = GlobalAlloc(GMEM_ZEROINIT Or GMEM_MOVEABLE Or GMEM_DDESHARE, uGblLen)
          mPtr = GlobalLock(hGblFiles)
          CopyMemory mPtr, VarPtr(dropFiles), uDropFilesLen
          mPtr = mPtr + uDropFilesLen
          hGblEffect = StrPtr(FName)
          I = LenB(FName)
          CopyMemory mPtr, hGblEffect, I
          GlobalUnlock hGblFiles
          SetClipboardData CF_HDROP, hGblFiles
        End If
        CloseClipboard
      End If
    End Sub

此clipCopyFile过程只处理单个的文件（已被我修改了），需要一次处理多个文件的，可去EXCEL HOME论坛查看源码。

微信发文件代码：

Sub 发文件()
    Set ws = CreateObject("wscript.shell")
    ws.SendKeys "^%w"
For I = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    ws.Run "mshta vbscript:ClipboardData.SetData(""Text""," & Chr(34) & Cells(I, 1) & Chr(34) & ")(close)", 0, True
    Sleep 300
    ws.SendKeys "^f"
    Sleep 1000
    ws.SendKeys "^v"
    Sleep 500
    ws.SendKeys "{ENTER}"
    Sleep 500
    ws.Run "mshta vbscript:ClipboardData.SetData(" & Chr(34) & "Text" & Chr(34) & "," & Chr(34) & Cells(I, 2) & Chr(34) & ")(close)", 0, True
    Sleep 500
    ws.SendKeys "^v"
    Sleep 500
    ws.SendKeys "{ENTER}"
    wjName = Cells(I, 3).Value
    clipCopyFile wjName
    ws.SendKeys "^v"
    Sleep 500
    ws.SendKeys "{ENTER}"
Next I
    Set ws = Nothing
End Sub