2016-05-25 43 views
1

用戶提交表單後,我正在運行幾個子表。但是,一旦vbs開始啓動後臺運行excel的代碼部分並運行一個宏,計時器就會掛起。想知道如何改進我的代碼來解決這個問題/如果可能的話。提前致謝。VBS計時器未通過HTA更新/刷新

<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> 
+0

如果您問爲什麼計時器在宏運行後掛起,請分享宏。 – omegastripes

回答

0

所以,如果有人運行到這個問題,這可能是解決的辦法就是實際調用Excel工作表,並觸發宏簡單地調用VBS與Excel工作簿中的子分開。

I.e.

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 

這不是我的答案,但專家交換其他用戶。儘管工作完美。