VBS 计时器不是 updating/refreshing 通过 HTA

Question

一旦用户提交表单，我就会运行几个订阅者。但是，一旦 vbs 启动在后面启动 excel 并运行宏的代码部分，计时器就会挂起。想知道如何改进我的代码来解决这个问题/如果可能的话。提前致谢。

 <html>
 <title>Report Generation</title>
 <head>
 <HTA:APPLICATION 
    APPLICATIONNAME="Report Generation"  
    SCROLL="No"
    CAPTION="yes"
    MAXIMIZEBUTTON="no"
    MINIMIZEBUTTON="no"
    SINGLEINSTANCE="yes"
    WINDOWSTATE="normal"
    SYSMENU="no"
    BORDER="thin"
    BORDERSTYLE="Normal"
    CONTEXTMENU="no"
    SELECTION="no">
 </head>

 <style>
 BODY
 {
 background-color: buttonface;
 Font: arial,sans-serif
 margin-top: 10px;
 margin-left: 20px;
 margin-right: 20px;
 margin-bottom: 5px;
 }
 .button
 {
 width: 91px;
 height: 25px;
 font-family: arial,sans-serif;
 font-size: 8pt;
 }
 td
 {
 font-family: arial,sans-serif;
 font-size: 10pt;
 }                     
 #scroll
 {
 height:100%;
 overflow:auto;
 }
 SELECT.FixedWidth 
 {
 width: 17em;  /* maybe use px for pixels or pt for points here */
 }
 </style>

 <script language="vbscript">
 'Option Explicit

    Dim pbTimerID
    Dim pbHTML 
    Dim pbWaitTime
    Dim pbHeight
    Dim pbWidth
    Dim pbBorder
    Dim pbUnloadedColor
    Dim pbLoadedColor
    Dim pbStartTime 
    Dim sitecode
    Dim objExcel  
    Dim objWorkbook
    Dim objSheet  

    'window size
    Dim WinWidth : WinWidth = 350
    Dim WinHeight : WinHeight = 330
    Window.ResizeTo WinWidth, WinHeight

 Sub Sleep(lngDelay)
    CreateObject("WScript.Shell").Run "Timeout /T " & lngDelay & " /nobreak", 0, True
 End Sub

 Sub sleepy
    Set objShell = CreateObject("WScript.Shell")
    strCmd = "%COMSPEC% /c"
    objShell.Run strCmd,0,1
End Sub 

 Sub CheckBoxChange
    If CheckBox(0).Checked Then
    ExecuteScoreCard
    Else
    MsgBox "CheckBox is not checked"
    End If
 End Sub

 Sub ExecuteScoreCard() 
    sleepy
    disablebtns
    sleepy  
    ProgressBarViz
    sleepy
    dim fso: set fso = CreateObject("Scripting.FileSystemObject")
    dim path: path = fso.GetAbsolutePathName(".")

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Automationsecurity = 1
    Set objWorkbook = objExcel.Workbooks.Open(path & "\Scorecard.xlsm")
    Set objSheet = objWorkbook.Worksheets("Cover Tab") 

    sitecode = document.getElementById("sitecode").value

    objSheet.Cells(4, 2) = sitecode
    objExcel.Run "Scorecard.xlsm!Module2.RefreshConns"
    Sleep 60 

    objExcel.ActiveWorkbook.SaveAs path & "\Scorecards\" & "Scorecard_" & sitecode & "_" & Year(Now()) & Month(Now()) & Day(Now()) & "_" & Hour(Now()) & Minute(Now()) &".xlsm", 52
    objExcel.ActiveWorkbook.Close
    objExcel.Quit   

    DoAction1

    enablebtns

 End Sub

 Sub ProgressBarViz
    ' Progress Bar Settings
    pbWaitTime = 180        ' How many seconds the progress bar lasts
    pbHeight = 20       ' Progress bar height
    pbWidth= 285        ' Progress bar width
    pbUnloadedColor="white"     ' Color of unloaded area
    pbLoadedColor="black"       ' Color of loaded area
    pbBorder="grey"     ' Color of Progress bar border
    ' Don't edit these things
    sleepy
    pbStartTime = now()
    sleepy
    rProgressbar
    sleepy
    pbTimerID = window.setInterval("rProgressbar", 200)
    sleepy
 end sub

 Sub rProgressbar

    pbHTML = ""
    pbSecsPassed = DateDiff("s",pbStartTime,Now)
    pbMinsToGo =  Int((pbWaitTime - pbSecsPassed) / 60)
    pbSecsToGo = Int((pbWaitTime - pbSecsPassed) - (pbMinsToGo * 60))

    if pbSecsToGo < 10 then
        pbSecsToGo = "0" & pbSecsToGo 
    end if

    pbLoadedWidth = (pbSecsPassed / pbWaittime) * pbWidth
    pbUnloadedWidth = pbWidth - pbLoadedWidth
    pbHTML = pbHTML & "<table border=1 bordercolor=" & pbBorder & " cellpadding=0 cellspacing=0 width=" & pbWidth & "><tr>"
    pbHTML = pbHTML & "<th width=" & pbLoadedWidth & " height=" & pbHeight & "align=left bgcolor="  & pbLoadedColor & "></th>"
    pbHTML = pbHTML & "<th width=" & pbUnloadedWidth & " height=" & pbHeight & "align=left bgcolor="  & pbUnLoadedColor & "></th>"
    pbHTML = pbHTML & "</tr></table><br>"
    pbHTML = pbHTML & "<table border=0 cellpadding=0 cellspacing=0 width=" & pbWidth & "><tr>"
    pbHTML = pbHTML & "<td align=center width=" & pbWidth & "% height=" & pbHeight & ">" & pbMinsToGo & ":" & pbSecsToGo & " remaining</td>"
    pbHTML = pbHTML & "</tr></table>"
    progressbar.InnerHTML = pbHTML

    sleepy

    if DateDiff("s",pbStartTime,Now) >= pbWaitTime then
        StopTimer
    end if

 End Sub

 Sub disablebtns
 btnSubmit.disabled = True
 btnExit.disabled = True
 end Sub

 Sub enablebtns
 btnSubmit.disabled = False
 btnExit.disabled = False
 end Sub

 Sub StopTimer
    window.clearInterval(PBTimerID)
 End Sub

 Sub DoAction1
    MsgBox ("Successfully generated scorecard.")
 End Sub

 Sub DoAction2
    MsgBox ("Successfully generated report2.")
 End Sub

 Sub DoAction3
    MsgBox ("Successfully generated report3.")
 End Sub

 Sub ExitProgram
    window.close()
 End Sub

 </script>

 <body>
 Site Code: <input type="inputbox" name="sitecode" id="sitecode">
 <br><br>
 <input type="checkbox" name="CheckBox"> Scorecard
 <br>
  <input type="checkbox" name="CheckBox"> Report2
 <br>
  <input type="checkbox" name="CheckBox"> Report3
 <br>
 <br>
 <span id = "progressbar"></span>
 <br>
 <div align="center">
  <input type="button" name="accept" id="btnSubmit" value="Submit" onclick="CheckBoxChange" style="height:30px; width:100px">
  <input type="button" name="abort" id="btnExit" value="Exit" onClick="ExitProgram" style="height:30px; width:100px">
  <br>
 </body>
 </html>

Answer 1

所以如果有人遇到这个问题，解决这个问题的方法是将实际调用 excel sheet 和触发宏的子程序分开，然后简单地调用 vbs 和excel 工作簿。

即

Sub ExecuteScoreCard() 
   sleepy
   disablebtns
   sleepy  
   ProgressBarViz
   sleepy

   Set wsh = CreateObject("WScript.Shell")
   set fso = CreateObject("Scripting.FileSystemObject")
   wsh.Run fso.GetAbsolutePathName(".") & "\refresh.vbs " & """" & document.getElementById("sitecode").value & """", 7, False
   set fso = Nothing
   set wsh = Nothing

   Sleep 10

   DoAction1

   enablebtns

End Sub

Refresh.vbs

If WScript.Arguments.Count > 0 Then
    sitecode = Wscript.Arguments(0)
Else
    WScript.Quit
End If

set fso = CreateObject("Scripting.FileSystemObject")
path = fso.GetAbsolutePathName(".")

Set objExcel = CreateObject("Excel.Application")
objExcel.Automationsecurity = 1
Set objWorkbook = objExcel.Workbooks.Open(path & "\Scorecard.xlsm")
Set objSheet = objWorkbook.Worksheets("Cover Tab") 

objSheet.Cells(4, 2) = sitecode

objExcel.Run "Scorecard.xlsm!Module2.RefreshConns"

objExcel.ActiveWorkbook.SaveAs path & "\Scorecards\" & "Scorecard_" & sitecode & "_" & Year(Now()) & Month(Now()) & Day(Now()) & "_" & Hour(Now()) & Minute(Now()) &".xlsm", 52
objExcel.ActiveWorkbook.Close
objExcel.Quit

这不是我的回答，而是专家交流中的另一个用户。不过效果很好。

VBS 计时器不是 updating/refreshing 通过 HTA

VBS timer isn't updating/refreshing via HTA

vbscript

hta