Here is the HTA I am working on. I think the article you linked to
about updating the display is taken care of using the Sleep function I
wrote. The problem I am having is if I close the window using the X in
the upper-right corner. The mshta.exe continues to run. If I use the
End button, the mshta will quit.
<html>
<!--'************************************************
'***************************************************
-->
<head>
<hta:application id="VSSCompHTA"
APPLICATIONNAME="SourceSafe Compile"
BORDER="thin"
BORDERSTYLE="normal"
CAPTION="yes"
CONTEXTMENU="yes"
ICON=""
INNERBORDER="yes"
MAXIMIZEBUTTON="yes"
MINIMIZEBUTTON="yes"
NAVIGABLE="yes"
SELECTION="yes"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SYSMENU="yes"
SCROLL="yes"
VERSION="1.00"
WINDOWSTATE="normal">
<meta http-equiv="Content-Type" content="text/html;
charset=windows-1252">
<meta name="GENERATOR" content="Microsoft FrontPage 4.0">
<meta name="ProgId" content="FrontPage.Editor.Document">
<title> VSSComp - SourceSafe Compiles</title>
</head>
<script language="vbscript">
' To Encode: screnc /e html rapidhta.hta Rapid.hta
Option Explicit
On Error Resume Next
Dim fso
Dim WshShell
Dim WshNetwork
Dim fil 'As Scripting.File
Dim fils 'As Scripting.Files
Dim fol 'As Scripting.Folder
Dim fols 'As Scripting.Folders
Dim LogMessage
Dim LogFileName
Dim LogFile
Dim cvDate
Dim Log
Dim vbQuote
Dim WindowsDir
Dim StartTime
Dim StopFlag
Dim HostIP
Dim Version
Dim AppName
Dim ProgName
Dim SourceType
Dim WFLPipe
Dim WFLError
Const ForReading = 1, ForWriting = 2, ForAppending = 8
vbQuote = Chr(34)
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
Set WshNetwork = CreateObject("WScript.Network")
WindowsDir = WshShell.ExpandEnvironmentStrings("%windir%") & "\"
Set cvDate = new cvDateFormat
Set Log = New WriteLog
StopFlag = False
HostIP = "10.117.48.2"
Version = "2"
AppName = "3"
ProgName = "4"
SourceType = "5"
Sub End_onclick()
document.close
Window.Close
StopFlag = True
End Sub
Sub onbeforeunload
document.close
Window.Close
StopFlag = True
End Sub
Sub OnLoad
StartTime = Now()
UpperDiv.InnerHTML = "<b>Processing started at: " &
cvDate.FixDate(StartTime, "mm/dd/yyyy") & _
" " & cvDate.FixTime (StartTime, "Long") & "</b>"
document.VSSComp.END.disabled = False
document.VSSComp.START.disabled = False
End Sub
Sub Start_Onclick()
On Error Resume Next
Do
document.VSSComp.END.disabled = False
document.VSSComp.START.disabled = True
Stop
If StopFlag = True Then
alert("StopFlag1")
'document.parentNode.removeChild
Exit Sub
End If
WriteMessage "Waiting...."
Sleep (8)
Log.ProcessLogFiles
Log.WriteLog "StopFlag: " & StopFlag, True
If StopFlag = True Then
alert("StopFlag2")
Exit Sub
End If
ProcessFiles
Loop
End Sub
Sub ProcessFiles
On Error Resume Next
WriteMessage "Processing the WFL"
CreateWFLPipe HostIP, "SystemDisk", "COMPILE\START\" & SourceType &
Version & AppName & ProgName
WriteWFLPipe ""
WriteWFLPipe "USER=ITI;"
WriteWFLPipe "FAMILY DISK = DISK ONLY;"
WriteWFLPipe "DISPLAY " & Chr(34) & "BEGINNING JOB COMPILE/START/"
& SourceType & Version & AppName & ProgName & Chr(34) & ";"
WriteWFLPipe "RUN *SYSTEM/FTPUTILITY;"
WriteWFLPipe " FILE FTPIN = *TSS" & Version & "/" & AppName & "/"
& ProgName & "/FTP ON D;"
WriteWFLPipe " FILE FTPOUT (TITLE = *TSS" & Version & "/" &
AppName & "/" & ProgName & " ON D, FILEKIND=COBOL85SYMBOL);"
WriteWFLPipe "RUN *SYSTEM/FTPUTILITY;"
WriteWFLPipe " FILE FTPIN = *TSS" & Version & "/" & AppName & "/"
& ProgName & "/CNF ON D;"
WriteWFLPipe " FILE FTPOUT (TITLE = *CNF/A/C" & Version & "/" &
AppName & "/" & ProgName & " ON D, FILEKIND=DATA);"
WriteWFLPipe "RUN *SYSTEM/FTPUTILITY;"
WriteWFLPipe " FILE FTPIN = *TSS" & Version & "/" & AppName & "/"
& ProgName & "/WFL ON D;"
WriteWFLPipe " FILE FTPOUT (TITLE = *COMPILE/" & SourceType &
Version & AppName & ProgName & " ON DISK, FILEKIND=JOBSYMBOL);"
WriteWFLPipe "IF FILE *COMPILE/" & SourceType & Version & AppName &
ProgName & " ON DISK IS RESIDENT THEN"
WriteWFLPipe " PROCESS START *COMPILE/" & SourceType & Version &
AppName & ProgName & " ON DISK;"
WriteWFLPipe "REMOVE *TSS" & Version & "/" & AppName & "/" &
ProgName & "/FTP ON D;"
WriteWFLPipe "REMOVE *TSS" & Version & "/" & AppName & "/" &
ProgName & "/CNF ON D;"
WriteWFLPipe "REMOVE *TSS" & Version & "/" & AppName & "/" &
ProgName & "/WFL ON D;"
WriteWFLPipe "REMOVE *COMPILE/START/" & SourceType & Version &
AppName & ProgName & " ON DISK;"
CloseWFLPipe
StartWFLPipe HostIP, "Disk", "-COMPILE\START\" & SourceType &
Version & AppName & ProgName, True
End Sub
Function Sleep (WaitTime)
Dim WaitFile
On Error Resume Next
If Not fso.FileExists ("Wait.vbs") Then
Set WaitFile = fso.OpenTextFile ("Wait.vbs", ForWriting, True)
WaitFile.WriteLine "Set objArgs = WScript.Arguments"
WaitFile.WriteLine "If objArgs.Count > 0 Then"
WaitFile.WriteLine " WaitTime = objArgs(0)"
WaitFile.WriteLine "Else"
WaitFile.WriteLine " WaitTime = " & vbQuote & "10" & vbQuote
WaitFile.WriteLine "End If"
WaitFile.WriteLine "WScript.Sleep WaitTime * 1000"
WaitFile.Close
End If
WshShell.Run "Wait.vbs " & WaitTime, 0, TRUE
End Function
Function WriteMessage (Message)
Dim WriteNow
Dim I
WriteNow = Now()
OutPut.innerText = cvDate.FixDate(WriteNow, "mm/dd/yyyy") & " " &
cvDate.FixTime (WriteNow, "Long") & _
": " & Message
Sleep (1)
End Function
'''''''''' Create and Open and WFL Pipe Subroutine
Function CreateWFLPipe (WFLPipeHostName, WFLPipeShareName,
WFLPipeFileName)
Dim WFLPipeName
On Error Resume Next
Err.Clear
WshNetwork.MapNetworkDrive "", "\\" & HostIP & "\IPC$", False,
"ITI", ""
WFLPipeName = "\\" & WFLPipeHostName & "\PIPE\COPYX\JOB\" &
WFLPipeShareName & "\" & WFLPipeFileName
WFLPipeName = Replace(WFLPipeName, "\", "/")
WFLPipeName = UCase(WFLPipeName)
Set WFLPipe = fso.OpenTextFile(WFLPipeName, ForWriting, True)
If Err <> 0 Then
Log.ErrorMessage Err.number, Err.Description, "Error in
WFLProcess creating the WFL file " & WFLPipeName, True
WFLError = True
Exit Function
End If
WFLPipe.WriteLine ("BEGIN JOB "& Replace(UCase(WFLPipeFilename),
"\", "/") & ";")
End Function
Function WriteWFLPipe (WFLPipeText)
On Error Resume Next
Err.Clear
If WFLError = True Then
Exit Function
End If
WFLPipe.WriteLine Replace(UCase(WFLPipeText), "\", "/")
If Err <> 0 Then
Log.ErrorMessage Err.number, Err.Description, "Error in
WriteWFLPipe writing the WFL file " & WFLPipeName, True
WFLError = True
End If
End Function
Function CloseWFLPipe
If WFLError = True Then
Exit Function
End If
WriteWFLPipe ""
WriteWFLPipe "end job;"
WFLPipe.Write Chr(26) & CHR(26)
WFLPipe.close
If Err <> 0 Then
Log.ErrorMessage Err.number, Err.Description, "Error in WFLProcess
closing the WFL file " & WFLPipeName, True
WFLError = True
End If
End Function
Function StartWFLPipe (WFLPipeHostName, WFLPipePackName,
WFLPipeFileName, WaitOption)
Dim WFLPipeName
Dim WFLMsg
Dim X
On Error Resume Next
If WFLError = True Then
Exit Function
End If
If WFLPipePackName = "" Then
WFLPipePackName = "DISK"
End If
If Left(WFLPipeFileName, 1) = "*" Then
WFLPipeFileName = Replace(WFLPipeFileName, "*", "-")
End If
If Left(WFLPipeFileName, 1) <> "(" And Left(WFLPipeFileName, 1) <>
"-" And Left(WFLPipeFileName, 1) <> "_" Then
Log.WriteLog "Error in StartWFLPipe - the file name does not
include an * or a user code", True
WFLError = True
Exit Function
End If
WFLPipeName = UCase("\\" & WFLPipeHostName & "\PIPE\WFLD\" &
WFLPipeFileName & "\_ON_\" & WFLPipePackName)
WFLPipeName = Replace(WFLPipeName, "/", "\")
' Read PIPE for WFL status
Log.WriteLog "Starting workflow", True
Set WFLPipe = fso.OpenTextFile(WFLPipeName, ForReading, True)
If Err <> 0 Then
Log.ErrorMessage Err.number, Err.Description, "Error in WFLProcess
opening WFLD pipe for file " & WFLPipeName, True
WFLError = True
Exit Function
End If
If WaitOption = False Then
WflPipe.Close
Log.WriteLog "Not waiting for WFL response messages", True
Exit Function
End If
X = " "
Do While ASC(X) <> 26 and ASC(X) <> 63
X = WFLPipe.Read(1)
If ASC(X) <> 26 and ASC(X) <> 63 Then
WFLMsg = WFLMsg + x
End If
Err.Clear
Loop
WFLPipe.Close
Log.WriteLog "Finished workflow", True
Log.WriteLog "", True
WFLMsg = UCase(WFLMsg)
If Instr(WFLMsg, "[WFL1]") = 0 or Instr(WFLMsg, "[WFL2]") = 0 then
WFLMsg = " **** WFL Error **** " & vbCrlf & WFLMsg
Log.ErrorMessage Err.number, Err.Description, "Error in WFLProcess
during WFLD pipe read for " & WFLPipeName, True
WFLError = True
Exit Function
End If
End Function
'////////////////////////////////////////////////////////
Class WriteLog
Private Function m_LogFileName
m_LogFileName = Left(document.location.pathname,
InstrRev(document.location.pathname, "\")) & _
cvDate.FixDate (Now(), "mmddyyyy") & "." & _
Right(document.location.pathname,
Len(document.location.pathname) - InstrRev(document.location.pathname,
"\")) & _
".LOG.TXT"
m_LogFileName = Replace(m_LogFileName, "%20", " ")
End Function
Private Sub Class_Initialize
End Sub
Public Property Get LogFileName
LogFileName = m_LogFileName
End Property
Public Property Let LogFileName(FileName)
m_LogFileName = FileName
End Property
Public Function ProcessLogFiles
Dim fol
Dim fil
Dim fils
Dim ScriptPath
If fso.FileExists(m_LogFileName) Then
'Log.WriteLog "", True
'Log.WriteLog "", True
Exit Function
End If
Log.WriteLog String(30, "*"), True
Log.WriteLog "Log File " & m_LogFileName & " Created at " &
StartTime, True
Log.WriteLog "", True
Log.WriteLog String(30, "*"), True
Log.WriteLog "Cleaning up old log files...", True
ScriptPath = Replace(document.location.pathname, "%20", " ")
ScriptPath = Left(ScriptPath, InstrRev(ScriptPath, "\"))
Set fol = fso.GetFolder(ScriptPath)
Set fils = fol.Files
Err.Clear
For Each fil in fils
If Instr(UCase(fil.name), Ucase(document.location.pathname)
& ".LOG.TXT") > 0 _
and DateDiff("d", fil.DateCreated, Now) > 7 Then
Log.WriteLog fil.Name & " is being deleted - Date
Created - " & fil.DateCreated, True
fso.DeleteFile fil.name, True
End If
Next
Log.WriteLog "", True
End Function
Public Function ErrorMessage (ErrorNumber, ErrorDescription,
LogMessage, PrintDateFlag)
WriteLog "", PrintDateFlag
WriteLog "*** " & LogMessage & " Error Number: " & ErrorNumber
& " Error Description: " & _
ErrorDescription, PrintDateFlag
WriteLog "", PrintDateFlag
End Function
Public Function WriteLog (LogMessage, PrintDateFlag)
Dim WriteNow
Dim LogFile
WriteNow = Now()
Set LogFile = fso.OpenTextFile(LogFileName, ForAppending,
True)
If PrintDateFlag = False Then
LogFile.WriteLine Space(Len(cvDate.FixDate(WriteNow,
"mm/dd/yyyy") & " " & _
cvDate.FixTime (WriteNow, "Long") & ": ")) & LogMessage
Else
LogFile.WriteLine cvDate.FixDate(WriteNow, "mm/dd/yyyy") &
" " & _
cvDate.FixTime (WriteNow, "Long") & ": " & LogMessage
End If
LogFile.Close
End Function
End Class
'////////////////////////////////////////////////////////
Class cvDateFormat
' Use: FixDate(valid date string, format string)
Public Function FixDate(strDate,format)
Dim d
Dim m
Dim y
d = DatePart("D",strDate)
m = DatePart("M",strDate)
y = DatePart("YYYY",strDate)
If Len(d) < 2 Then
d = "0" & d
End If
If Len(m) < 2 Then
m = "0" & m
End If
Select Case LCase(Format)
Case LCase("yyyy/mm/dd")
FixDate = y & "/" & m & "/" & d
Case LCase("yy/mm/dd")
FixDate = right(y,2) & "/" & m & "/" & d
Case LCase("dd/mm/yy")
FixDate = d & "/" & m & "/" & right(y,2)
Case LCase("dd/mm/yyyy")
FixDate = d & "/" & m & "/" & y
Case LCase("yyyy-mm-dd")
FixDate = y & "-" & m & "-" & d
Case LCase("yy-mm-dd")
FixDate = right(y,2) & "-" & m & "-" & d
Case LCase("dd-mm-yy")
FixDate = d & "-" & m & "-" & right(y,2)
Case LCase("dd-mm-yyyy")
FixDate = d & "-" & m & "-" & y
Case LCase("mm/dd/yyyy")
FixDate = m & "/" & d & "/" & y
Case LCase("ddmmyyyy")
FixDate = d & m & y
Case LCase("ddmmyy")
FixDate = d & m & right(y,2)
Case LCase("mmddyy")
FixDate = m & d & right(y,2)
Case LCase("mmddyyyy")
FixDate = m & d & y
Case LCase("yyyymmdd")
FixDate = y & m & d
Case LCase("yymmdd")
FixDate = right(y,2) & m & d
Case LCase("yyyy")
FixDate = y
Case LCase("short")
FixDate = FormatDateTime(strDate,vbShortDate)
Case LCase("long")
FixDate = FormatDateTime(strDate,vbLongDate)
Case LCase("dd-month-yyyy")
m = MonthName (m, True)
FixDate = d & "-" & m & "-" & y
Case LCase("dd-month-yy")
m = MonthName (m, True)
FixDate = d & "-" & m & "-" & right(y,2)
Case LCase("dayname")
FixDate = WeekDayName(Weekday(strDate), False)
Case LCase("daynameabbr")
FixDate = WeekDayName(Weekday(strDate), True)
Case LCase("sitedate")
FixDate = WeekDayName(Weekday(strDate), False) & ", " &
DateSuffix(DatePart("D",strDate)) & _
" of " & MonthName(m, False) & ", " &
FixDate(strDate,"yyyy")
Case LCase("stamp")
FixDate = fixdate(Now(),"yyyymmdd") &
FixTime(Now(),"Stamp")
Case Else
FixDate = d & "/" & m & "/" & y
End Select
End Function
Private Function DateSuffix(num)
Dim x
If num < 13 or num > 20 Then
Select Case Right(num,1)
Case "0"
x = "th"
Case "1"
x = "st"
Case "2"
x = "nd"
Case "3"
x = "rd"
Case else
x = "th"
End Select
End If
If num > 12 and num < 21 Then
x = "th"
End If
DateSuffix = num & x
End Function
Public Function FixTime(strTime,format)
Dim h
Dim m
Dim s
h = Hour(strTime)
m = Minute(strTime)
s = Second(strTime)
If s < 10 Then
s = "0" & s
End If
If m < 10 Then
m = "0" & m
End If
If h < 10 Then
h = "0" & h
End If
Select Case LCase(format)
Case LCase("hh:mm:ss")
FixTime = h & ":" & m & ":" & s
Case LCase("hhmmss")
FixTime = h & m & s
Case LCase("Stamp")
FixTime = h & m & s
Case LCase("Long")
FixTime = FormatDateTime(strTime,vbLongTime)
Case LCase("Short")
FixTime = FormatDateTime(strTime,vbShortTime)
Case Else
FixTime = FormatDateTime(strTime,vbShortTime)
End Select
End Function
End Class
'////////////////////////////////////////////////////////
</script>
<body onload="OnLoad" onbeforeunload="onbeforeunload" style="font:10pt
verdana">
<form name="VSSComp">
<!--
<p align="center"><img id="logo" border="0" src="itilogo1.jpg"
width="157" height="60" alt="Rapid Input Form"></p>
-->
<p align="center"><em><font size="5">SourceSafe
Compiles</font></em></p>
<hr>
<p align="center"><input type="button"
Style="height:30;width:70;position:relative" value="Start"
name="START">
<input type="button" Style="height:30;width:70;position:relative"
value="End" name="END"> </p>
</form>
</body>
<CENTER>
<font face='arial black'>
<hr color='black'>
</font>
<font color='red'>
<Div align="center" ID="UpperDiv"></Div>
</font>
<font face='arial black'>
<hr color='black'>
</font>
<Div align="left" ID="OutPut"></Div>
<font face='arial black'>
<hr color='BLACK'>
</font>
</CENTER>
</html>