时间戳

首页 > 解决方案 > 用户操作后如何继续循环？

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

问题描述

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

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

我的问题是 for 循环只是继续，并没有让用户有时间保存文件。我知道一种方法是使用 a 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

标签： excelvbapdfsendkeyssave-as

解决方案

所以 - 这很有趣。

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

当“另存为”对话框打开时，使用此处的宏延迟宏： 延迟宏以允许事件完成

关闭后，窗口将不再可见，因此宏将恢复。

警告：目前它只会在没有“另存为”的窗口存在时才会进行。我想实施父/子检查以确保它是正在检查的 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

推荐阅读