用户操作后如何继续循环？

Question

我正在尝试找到一种方法让系统暂停For 循环，直到用户完成保存 PDF。我在这个程序中使用SendKeys，下面的代码行打开了SaveAs 菜单，用户可以在其中命名文件并选择文件路径。

Application.SendKeys "+^(s)", True

我的问题是 for 循环只是继续，并没有让用户有时间保存文件。我知道一种方法是使用Application.Wait Now，但用户查找路径和命名文件所需的时间会有所不同。有没有等到对话框关闭？

编辑：我正在向 PDF 表单发送密钥并尝试保存 PDF 表单。

代码：

Sub testingThis()

    Dim aFieldName As String
    Dim pdfFilePath As String
    Dim outputFolderPath As String
    Dim WasSaved As Variant
    Dim nonFormattedFolderPath As String
    Dim i As Long


    Dim wb As Workbook
    Dim WS As Excel.Worksheet

    Set wb = ActiveWorkbook
    Set WS = wb.Sheets("Entry Form Test")

    Dim lastRowUsed As Long
    lastRowUsed = LastRow
    Dim pdfCounter As Long
    pdfCounter = 1



    pdfFilePath = GetPDFPath("Select the Empty PDF Form")
    outputFolderPath = GetFolder
    nonFormattedFolderPath = outputFolderPath


    ThisWorkbook.FollowHyperlink pdfFilePath

       For i = 3 To 3 'lastRowUsed

            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("D" & i).Text, True
            Application.Wait Now + 0.000001

            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("E" & i).Text, True
            Application.Wait Now + 0.000001

            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("G" & i).Text, True
            Application.Wait Now + 0.00005

            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("H" & i).Value, True
            Application.Wait Now + 0.000001


            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("J" & i).Text, True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("K" & i).Text, True
            Application.Wait Now + 0.000001



            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("I" & i).Text, True
            Application.Wait Now + 0.000001


            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("M" & i).Text, True
            Application.SendKeys "{Return}", True
            MsgBox WS.Range("N" & i).Text
            Application.SendKeys WS.Range("N" & i).Text, True
            Application.Wait Now + 0.000001


            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("L" & i).Text, True
            Application.Wait Now + 0.000001

            Application.SendKeys "{Tab}", True

            Application.SendKeys "{Tab}", True
            Application.SendKeys WS.Range("O" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("p" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("q" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("r" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("s" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("t" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("u" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("v" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("w" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("x" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("y" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("z" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("aa" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ab" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ac" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ad" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ae" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("af" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ag" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ah" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ai" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("aj" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("ak" & 2).Text & ":", True
            Application.SendKeys "{Return}", True
            Application.SendKeys WS.Range("al" & 2).Text & ":", True
            Application.Wait Now + 0.000001

            'SAVE AND LOOP BACK HERE

End Sub

Function GetPDFPath(theText As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFilePicker)
    With fldr
        .Title = theText
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetPDFPath = sItem
    Set fldr = Nothing
End Function

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select the Folder to Place the Completed DD1144 Forms"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function


Function LastRow()
    LastRow = Range("a65536").End(xlUp).Row
End Function

Private Sub FlowchartProcess1_Click()
    Call WriteToAdobeFields
End Sub

Answer 1

所以 - 解决这个问题非常有趣。

基本上 sub 使用 Shell 而不是 FollowHyperlink 打开一个 pdf（最初的想法是使用 processID，但到目前为止我还没有让它正常工作）然后使用 SendKeys 触发“另存为”对话框（如问题)。

“另存为”对话框打开时，使用此处的宏会延迟宏： Delay macro to allow events to finish

一旦关闭，窗口将不再可见，因此宏会继续运行。

警告：目前只有在没有“另存为”的窗口存在时才会进行。我想实施父/子检查，以确保正在检查的是 Adob​​e Reader 窗口，但到目前为止还没有完全正常工作。

Private Declare Function IsWindowVisible Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Sub TestPDFForm()

    Dim pdfFilePath As String: pdfFilePath = GetFilePath("Select the empty PDF form")
    'Dim outputPath As String: outputPath = GetFolderPath("Select the folder to save the completed DD1144 forms")
    'If pdfFilePath = "-" Or outputPath = "-" Then Exit Sub

    Dim ProcID As Long

    Dim sh As Object: Set sh = CreateObject("WScript.Shell")
    Dim AdobeExe As String: AdobeExe = sh.RegRead("HKCR\Software\Adobe\Acrobat\Exe\")

    ProcID = RunShell(AdobeExe, pdfFilePath)

    Application.SendKeys "+^(s)", True
    Delay (2.5) ' Delay until "Save As" dialog has opened

    Debug.Print Timer
    Do     ' Delay until window has been closed
        Delay (0.5)
    Loop While IsWindowVisible(FindSaveAs) <> 0
    Debug.Print Timer

End Sub

Function FindSaveAs() As Long
    FindSaveAs = FindWindow(vbNullString, "Save As")
End Function

Function RunShell(path As String, Optional arguments As String, Optional windowstyle As VbAppWinStyle = vbNormalFocus) As Long
    If arguments <> "" Then path = path & " """ & arguments & """"
    RunShell = Shell(path, windowstyle)
End Function

Function GetFilePath(caption As String) As String
    Dim sItem As String: sItem = "-"
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = caption
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFilePath = sItem
End Function

Function GetFolderPath(caption As String) As String
    Dim sItem As String: sItem = "-"
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = caption
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolderPath = sItem
End Function

Function Delay(Seconds As Single) ' Millisecond precision
    Dim StopTime As Single: StopTime = Timer + Seconds
    Do While Timer < StopTime
        DoEvents
    Loop
End Function