Excel VBA SendKeys 在尝试发送到 Excel 加载项时不起作用

Question

简介。：在我公司，我们在 Excel 中安装了一个安全插件，阻止我们在不输入的情况下保存新的 Excel 工作簿需要的参数。

挑战：使用 SendKeys 发送此 Excel 加载项所需的密钥。

问题：当加载项屏幕弹出时（如下面的屏幕截图所示），代码似乎没有继续到这一行： SendKeys " ", True.

我的代码（相关部分）

编辑 1：下面的代码在 For 循环内，我正在为每个用户向该用户导出一个 filterred 数据库。因此，每次我尝试为其中一个用户保存文件时，我都会遇到加载项（我需要 "by-pass" 它在 For 循环中）。

' sort the PM's workbook , hide source data    
Application.DisplayAlerts = False
NewWB.Sheets("Combined").Visible = False
NewWB.Sheets("Sheet3").Delete
NewWB.SaveAs "Budget usage - " & Year(Date) & "-" & Month(Date - 30) & " " & PMList(r)

Dim i    As Long

SendKeys " ", True ' <-- it doesn't get to this line when the Excel Add-In pops up
For i = 1 To 3
    SendKeys "+{DOWN}", True
Next i
SendKeys "{ENTER}", True
For i = 1 To 4
    SendKeys "+", True
Next i
SendKeys "{ENTER}", True

Answer 1

您启动插件弹出窗口的事实 "froze" 代码。我不知道如何在 VBA 中异步执行此操作（现在我开始使用 VB.NET 我对这些事情感觉好多了！）。我能想到的最好的是： - 保存在一个临时文件（temp.vbs for ex）一些代码和运行它在启动表单之前：

Dim s$
s = "Set WshShell = WScript.CreateObject(""WScript.Shell"")" & vbNewLine & _
    "WScript.Sleep 6000" & vbNewLine & _
    "WshShell.SendKeys ""+{TAB}""" & vbNewLine & _
    "WshShell.SendKeys ""~"""
CreateObject("Scripting.FileSystemObject").createtextfile(FileName).write s
shell(filename)

Answer 2

看起来您的插件在保存事件之前正在下沉应用程序工作簿，因此允许保存的快速修复是再次下沉它，因此在您的代码中，具有以下内容

在普通模块中有以下

Public cResink As clsResinkApplication

有一个名为 clsResinkApplication 的 class，class 的代码如下

Private WithEvents resinkApp As Excel.Application

Public Sub init2(appToResink As Excel.Application)
    Set resinkApp = appToResink
End Sub
Private Sub resinkApp_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    ActiveWorkbook.SaveAs "test.xlsx"
End Sub

然后在打开的工作簿中可以有如下内容

Private Sub Workbook_Open()

Set cResink = New clsResinkApplication
cResink.init2 Application

End Sub

这应该在插件的之前转移到您的保存槽。

Answer 3

Public Sub TryMe()

    Dim s           As String
    Dim sPath       As String
    Dim sTitle      As String: sTitle = "runme.vbs"

    s = "Set WshShell = WScript.CreateObject(""WScript.Shell"")" & vbNewLine & _
        "WScript.Sleep 6000" & vbNewLine & _
        "WshShell.SendKeys ""+{TAB}""" & vbNewLine & _
        "WshShell.SendKeys ""~"""

    CreateObject("Scripting.FileSystemObject").createtextfile(sTitle).write s
    sPath = "wscript " & ThisWorkbook.Path & "\runme.vbs"
    Shell sPath, vbNormalFocus

End Sub

@Pierre - 你的想法是写这样的东西^^ ?

然后在调用表单之前调用它，然后在某个地方删除它？最初我认为你不会在任何地方创建文件，但现在我已经尝试过并且我注意到了。应该可以。

Answer 4

感谢@Vityata 和@Pierre 提出了使用 VBScript 的想法，并在 VBA 代码中编写了 VBScipt 的内容。

我最后做的是：

1. 在调用我的保存之前添加了 Call WShellSendKeys。

'========== Call the VBScript to run a Shell to send to Keys in the background ======
Call WShellSendKeys        
NewWB.SaveAs "Budget usage - " & Year(Date) & "-" & Month(Date - 30) & " " & PMList(r)

2. 检查VBScirt是否已经存在，如果不存在则创建它。

Public Sub WShellSendKeys()

Dim wsh         As Object
Dim objFile     As Object
Dim objFSO      As Object

Set wsh = VBA.CreateObject("WScript.Shell")

If Dir(VBScrPath) <> "" Then  ' <-- VBS file name already exits in folder >> there's no need to re-create it, just run it
    ' Run Shell
    wsh.Run "wscript " & Chr(34) & VBScrPath & Chr(34), vbNormalFocus
Else ' VBS file name doesn't exits in folder >> create it
    Call WriteToVBS
    wsh.Run "wscript " & Chr(34) & VBScrPath & Chr(34), vbNormalFocus
End If

End Sub

3。另一个使用 SendKeys.

创建 VBScript 的 Sub

Sub WriteToVBS()

Dim objFile     As Object
Dim objFSO      As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(VBScrPath, 8, True)

' --- Text to write into the VBScript file ---
objFile.WriteLine ("Option Explicit")
objFile.WriteLine ("")
objFile.WriteLine ("Dim WshShell")
objFile.WriteLine ("Dim i")
objFile.WriteLine ("")
objFile.WriteLine ("Set WshShell = CreateObject(""WScript.Shell"")")
objFile.WriteLine ("WScript.Sleep(4000)")
objFile.WriteLine ("")
objFile.WriteLine ("WshShell.SendKeys ""{R}"",True")
objFile.WriteLine ("WScript.Sleep(1000)")
objFile.WriteLine ("For i = 1 To 2")
objFile.WriteLine ("WshShell.SendKeys ""{ENTER}"",True")
objFile.WriteLine ("WScript.Sleep(1000)")
objFile.WriteLine ("Next")

objFile.Close
Set objFile = Nothing
Set objFSO = Nothing

End Sub

Excel VBA SendKeys 在尝试发送到 Excel 加载项时不起作用

Excel VBA SendKeys not working when trying to Send to Excel Add-In

vba

excel

add-in

sendkeys