I'm running a few subs once the user submits the form. However, the timer hangs as soon as the vbs kicks off the portion of the code which launch excel in the back and runs a macro. Wondering how I can improve my code to fix this/ if it's possible. Thanks in advance.
<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>
So in case anyone runs into this issue, the way this could be resolved is to separate the sub that actually calls the excel sheet and triggers the macro and simply call the vbs versus the excel workbook.
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
And this was not my answer but another user on expert-exchange. Works perfectly though.
Related
how do I make a fake progress bar in VBScript?
I want to make a program that pretends it is downloading things.
I want to make it realistic by adding a moving progress bar, how do I do it, if it is possible?
Here is an example that can create a HTA ProgressBar while you download a file from internet :
Option Explicit
If AppPrevInstance() Then
MsgBox "The script is already launching" & vbCrlf &_
CommandLineLike(WScript.ScriptName),VbExclamation,"The script is already launching"
WScript.Quit
Else
Const Copyright = " by Hackoo 2018"
Dim Title : Title = "Get Header Location and download file" & Copyright
Const WHR_EnableRedirects = 6
Dim Default_Link,Base_Link,Dynamic_Link,Flag,Question,DirectLink,Save2File
Dim fso,ws,Temp,WaitingMsg,oExec
Default_Link = "https://downloads.malwarebytes.com/file/mb3/"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
' "https://downloads.malwarebytes.com/file/mb3/" 'Tested OK ==> Malwarebytes v3.5.1
' "https://download.toolslib.net/download/file/1/1511" 'Tested OK ==> Adwcleaner v7.1.1
' "https://www.google.tn/images/branding/googlelogo/1x/googlelogo_color_272x92dp.png" Tested OK ==> a direct link example
Base_Link = InputBox("Copy and paste your link here to get the response header",Title,Default_Link)
If CheckDirectLink(Base_Link) = True And Instr(Base_Link,"php") = 0 Then 'Check if it is a direct link
Save2File = GetFileNamefromDirectLink(Base_Link)
If Save2File = "" Then
MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
Wscript.Quit()
End If
WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
Call LaunchProgressBar() 'Launch of the Waiting Bar
Call Download(Base_Link,Save2File)
pause(3)
Call CloseProgressBar()
MsgBox "The download of the file : "& Save2File & vbCrlf &_
"is Completed !",vbInformation,Title
wscript.Quit()
End If
Call GetHeaderLocation(Base_Link)
If Flag = True And CheckDirectLink(GetHeaderLocation(Base_Link)) = True Then 'Checking for a direct link of Malwarebytes
Save2File = GetFileNamefromDirectLink(GetHeaderLocation(Base_Link))
If Save2File = "" Then
MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
Wscript.Quit()
End If
DirectLink = GetHeaderLocation(Base_Link)
'wscript.echo DirectLink & vbCrlf & Save2File
Question = MsgBox("Did you want to download this file ?" & vbCrlf &_
Save2File,vbQuestion+vbYesNo,Title)
If Question = vbYes Then
If Save2File <> "" Then
WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
Call LaunchProgressBar() 'Launch of the Waiting Bar
Call Download(DirectLink,Save2File)
Call CloseProgressBar()
MsgBox "The download of the file : "& Save2File & vbCrlf &_
"is Completed !",vbInformation,Title
Wscript.Quit()
End If
End If
ElseIf Instr(Base_Link,"toolslib") <> 0 And Flag = True Then 'for Adwcleaner
Dynamic_Link = Extract_Dynamic_Link(GetDataFromURL(Base_Link,"Get", ""))
Save2File = GetFileName(GetHeaderLocation(Dynamic_Link))
If Save2File = "" Then
MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
Wscript.Quit()
End If
Question = MsgBox("The Dynamic Link is = "& Dynamic_Link & vbcrlf & vbcrlf &_
"Response of The Dynamic Link is : "& vbcrlf & GetHeaderLocation(Dynamic_Link) & vbCrlf & vbCrlf &_
"Extracted FileName is = " & Save2File,vbYesNo+vbQuestion,Title)
If Question = vbYes Then
WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
Call LaunchProgressBar() 'Launch of the Waiting Bar
Call Download(Dynamic_Link,Save2File)
Call CloseProgressBar()
MsgBox "The download of the file : "& Save2File & vbCrlf &_
"is Completed !",vbInformation,Title
Else
Wscript.Quit()
End If
ElseIf Instr(Base_Link,"php") > 0 And Flag = False Then
Save2File = GetFileName(GetHeaderLocation(Base_Link)) ' for site of autoitscript.fr
If Save2File = "" Then
MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
Wscript.Quit()
End If
Question = MsgBox("Did you want to download this file ?" & vbCrlf &_
Save2File,vbQuestion+vbYesNo,Title)
If Question = vbYes Then
WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
Call LaunchProgressBar() 'Launch of the Waiting Bar
Call Download(Base_Link,Save2File)
pause(3)
Call CloseProgressBar()
MsgBox "The download of the file : "& Save2File & vbCrlf &_
"is Completed !",vbInformation,Title
Else
Wscript.Quit()
End If
End If
End If
'------------------------------------------------
Function GetHeaderLocation(URL)
On Error Resume Next
Dim h,GetLocation
Set h = CreateObject("WinHttp.WinHttpRequest.5.1")
h.Option(WHR_EnableRedirects) = False
h.Open "HEAD", URL , False
h.Send()
GetLocation = h.GetResponseHeader("Location")
If Err = 0 Then
Flag = True
GetHeaderLocation = GetLocation
Else
Flag = False
GetHeaderLocation = h.GetResponseHeader("Content-Disposition")
End If
End Function
'---------------------------------------------
Function GetFileName(Data)
Dim regEx, Match, Matches,FileName
Set regEx = New RegExp
regEx.Pattern = "\x27{2}(\w.*)"
regEx.IgnoreCase = True
regEx.Global = True
If regEx.Test(Data) Then
Set Matches = regEx.Execute(Data)
For Each Match in Matches
FileName = Match.subMatches(0)
Next
Else
Set regEx = New RegExp
regEx.Pattern = "\x22(\w.*)\x22"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(Data)
For Each Match in Matches
FileName = Match.subMatches(0)
Next
End If
GetFileName = FileName
End Function
'---------------------------------------------
Function Extract_Dynamic_Link(Data)
Dim regEx, Match, Matches,Dynamic_Link
Set regEx = New RegExp
regEx.Pattern = Base_Link & "\?s=[^""]*"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(Data)
For Each Match in Matches
Dynamic_Link = Match.Value
Next
Extract_Dynamic_Link = Dynamic_Link
End Function
'------------------------------------------------
Function GetDataFromURL(strURL, strMethod, strPostData)
Dim lngTimeout
Dim strUserAgentString
Dim intSslErrorIgnoreFlags
Dim blnEnableRedirects
Dim blnEnableHttpsToHttpRedirects
Dim strHostOverride
Dim strLogin
Dim strPassword
Dim strResponseText
Dim objWinHttp
lngTimeout = 59000
strUserAgentString = "http_requester/0.1"
intSslErrorIgnoreFlags = 13056 ' 13056: ignore all err, 0: accept no err
blnEnableRedirects = True
blnEnableHttpsToHttpRedirects = True
strHostOverride = ""
strLogin = ""
strPassword = ""
Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
objWinHttp.SetTimeouts lngTimeout, lngTimeout, lngTimeout, lngTimeout
objWinHttp.Open strMethod, strURL
If strMethod = "POST" Then
objWinHttp.setRequestHeader "Content-type", _
"application/x-www-form-urlencoded"
End If
If strHostOverride <> "" Then
objWinHttp.SetRequestHeader "Host", strHostOverride
End If
objWinHttp.Option(0) = strUserAgentString
objWinHttp.Option(4) = intSslErrorIgnoreFlags
objWinHttp.Option(6) = blnEnableRedirects
objWinHttp.Option(12) = blnEnableHttpsToHttpRedirects
If (strLogin <> "") And (strPassword <> "") Then
objWinHttp.SetCredentials strLogin, strPassword, 0
End If
On Error Resume Next
objWinHttp.Send(strPostData)
If Err.Number = 0 Then
If objWinHttp.Status = "200" Then
GetDataFromURL = objWinHttp.ResponseText
Else
GetDataFromURL = "HTTP " & objWinHttp.Status & " " & _
objWinHttp.StatusText
End If
Else
GetDataFromURL = "Error " & Err.Number & " " & Err.Source & " " & _
Err.Description
End If
On Error GoTo 0
Set objWinHttp = Nothing
End Function
'------------------------------------------------
Sub Download(URL,Save2File)
Dim File,Line,BS,ws
On Error Resume Next
Set File = CreateObject("WinHttp.WinHttpRequest.5.1")
File.Open "GET",URL, False
File.Send()
If err.number <> 0 then
Line = Line & vbcrlf & "Error Getting File"
Line = Line & vbcrlf & "Error " & err.number & "(0x" & hex(err.number) & ") " & vbcrlf &_
err.description
Line = Line & vbcrlf & "Source " & err.source
MsgBox Line,vbCritical,"Error getting file"
Err.clear
wscript.quit
End If
If File.Status = 200 Then ' File exists and it is ready to be downloaded
Set BS = CreateObject("ADODB.Stream")
Set ws = CreateObject("wscript.Shell")
BS.type = 1
BS.open
BS.Write File.ResponseBody
BS.SaveToFile Save2File, 2
ElseIf File.Status = 404 Then
MsgBox "File Not found : " & File.Status,vbCritical,"Error File Not Found"
Else
MsgBox "Unknown Error : " & File.Status,vbCritical,"Error getting file"
End If
End Sub
'------------------------------------------------
Function GetFileNamefromDirectLink(URL)
Dim ArrFile,FileName
ArrFile = Split(URL,"/")
FileName = ArrFile(UBound(ArrFile))
GetFileNamefromDirectLink = FileName
End Function
'------------------------------------------------
Function CheckDirectLink(URL)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = "(.exe|.zip|.rar|.msi|.vbs|.bat|.hta|.txt|.log|.doc" & _
"|.docx|.xls|.xlsx|.pdf|.mp3|.mp4|.avi|.png|.jpg|.jpeg|.bmp|.gif)"
regEx.IgnoreCase = True
regEx.Global = False
If regEx.Test(URL) Then
CheckDirectLink = True
End If
End Function
'------------------------------------------------
'**********************************************************************************************
Sub CreateProgressBar(Title,WaitingMsg)
Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = WS.ExpandEnvironmentStrings("%Temp%")
PathOutPutHTML = Temp & "\Barre.hta"
Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
fhta.WriteLine "<HTML>"
fhta.WriteLine "<HEAD>"
fhta.WriteLine "<Title> " & Title & "</Title>"
fhta.WriteLine "<HTA:APPLICATION"
fhta.WriteLine "ICON = ""magnify.exe"" "
fhta.WriteLine "BORDER=""THIN"" "
fhta.WriteLine "INNERBORDER=""NO"" "
fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
fhta.WriteLine "SCROLL=""NO"" "
fhta.WriteLine "SYSMENU=""NO"" "
fhta.WriteLine "SELECTION=""NO"" "
fhta.WriteLine "SINGLEINSTANCE=""YES"">"
fhta.WriteLine "</HEAD>"
fhta.WriteLine "<BODY text=""white""><CENTER>"
fhta.WriteLine "<marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & WaitingMsg &"</font></marquee>"
fhta.WriteLine "<img src=""data:image/gif;base64,R0lGODlhgAAPAPIAAP////INPvvI0/q1xPVLb/INPgAAAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh/hpDcmVhdGVkIHdpdGggYWpheGxvYWQuaW5mbwAh+QQJCgAAACwAAAAAgAAPAAAD5wiyC/6sPRfFpPGqfKv2HTeBowiZGLORq1lJqfuW7Gud9YzLud3zQNVOGCO2jDZaEHZk+nRFJ7R5i1apSuQ0OZT+nleuNetdhrfob1kLXrvPariZLGfPuz66Hr8f8/9+gVh4YoOChYhpd4eKdgwDkJEDE5KRlJWTD5iZDpuXlZ+SoZaamKOQp5wAm56loK6isKSdprKotqqttK+7sb2zq6y8wcO6xL7HwMbLtb+3zrnNycKp1bjW0NjT0cXSzMLK3uLd5Mjf5uPo5eDa5+Hrz9vt6e/qosO/GvjJ+sj5F/sC+uMHcCCoBAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/4ixgeloM5erDHonOWBFFlJoxiiTFtqWwa/Jhx/86nKdc7vuJ6mxaABbUaUTvljBo++pxO5nFQFxMY1aW12pV+q9yYGk6NlW5bAPQuh7yl6Hg/TLeu2fssf7/19Zn9meYFpd3J1bnCMiY0RhYCSgoaIdoqDhxoFnJ0FFAOhogOgo6GlpqijqqKspw+mrw6xpLCxrrWzsZ6duL62qcCrwq3EsgC0v7rBy8PNorycysi3xrnUzNjO2sXPx8nW07TRn+Hm3tfg6OLV6+fc37vR7Nnq8Ont9/Tb9v3yvPu66Xvnr16+gvwO3gKIIdszDw65Qdz2sCFFiRYFVmQFIAEBACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9J2qd1AoM9MYeF4KaWJKWmaJXxEyulI3zWa/39Xh6/vkT3q/DC/JiBFjMSCM2hUybUwrdFa3Pqw+pdEVxU3AViKVqwz30cKzmQpZl8ZlNn9uzeLPH7eCrv2l1eXKDgXd6Gn5+goiEjYaFa4eOFopwZJh/cZCPkpGAnhoFo6QFE6WkEwOrrAOqrauvsLKttKy2sQ+wuQ67rrq7uAOoo6fEwsjAs8q1zLfOvAC+yb3B0MPHD8Sm19TS1tXL4c3jz+XR093X28ao3unnv/Hv4N/i9uT45vqr7NrZ89QFHMhPXkF69+AV9OeA4UGBDwkqnFiPYsJg7jBktMXhD165jvk+YvCoD+Q+kRwTAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJdCLnC/S+nsCFo1dq5zeRoFlJ1Du91hOq3b3qNo/5OdZPGDT1QrSZDLIcGp2o47MYheJuImmVer0lmRVlWNslYndm4Jmctba5gm9sPI+gp2v3fZuH78t4Xk0Kg3J+bH9vfYtqjWlIhZF0h3qIlpWYlJpYhp2DjI+BoXyOoqYaBamqBROrqq2urA8DtLUDE7a1uLm3s7y7ucC2wrq+wca2sbIOyrCuxLTQvQ680wDV0tnIxdS/27TND+HMsdrdx+fD39bY6+bX3um14wD09O3y0e77+ezx8OgAqutnr5w4g/3e4RPIjaG+hPwc+stV8NlBixAzSlT4bxqhx46/MF5MxUGkPA4BT15IyRDlwG0uG55MAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPECwbnu3gUKH1h2ZziNKVlJWDW9FvSuI/nkusPjrF0OaBIGfTna7GaTNTPGIvK4GUZRV1WV+ssKlE/G0hmDTqVbdPeMZWvX6XacAy6LwzAF092b9+GAVnxEcjx1emSIZop3g16Eb4J+kH+ShnuMeYeHgVyWn56hakmYm6WYnaOihaCqrh0FsbIFE7Oytba0D7m6DgO/wAMTwcDDxMIPx8i+x8bEzsHQwLy4ttWz17fJzdvP3dHfxeG/0uTjywDK1Lu52bHuvenczN704Pbi+Ob66MrlA+scBAQwcKC/c/8SIlzI71/BduysRcTGUF49i/cw5tO4jytjv3keH0oUCJHkSI8KG1Y8qLIlypMm312ASZCiNA0X8eHMqPNCTo07iyUAACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9F8mk8ap8hffaB3ZiWJKfmaJgJWHV5FqQK9uPuDr6yPeTniAIzBV/utktVmPCOE8GUTc9Ia0AYXWXPXaTuOhr4yRDzVIjVY3VsrnuK7ynbJ7rYlp+6/u2vXF+c2tyHnhoY4eKYYJ9gY+AkYSNAotllneMkJObf5ySIphpe3ajiHqUfENvjqCDniIFsrMFE7Sztre1D7q7Dr0TA8LDA8HEwsbHycTLw83ID8fCwLy6ubfXtNm40dLPxd3K4czjzuXQDtID1L/W1djv2vHc6d7n4PXi+eT75v3oANSxAzCwoLt28P7hC2hP4beH974ZTEjwYEWKA9VBdBixLSNHhRPlIRR5kWTGhgz1peS30l9LgBojUhzpa56GmSVr9tOgcueFni15styZAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKsWIPiFwhia4kWWKrl5UGXFMFa/nJ0Da+r0rF9vAiQOH0DZTMeYKJ0y6O2JPApXRmxVe3VtSVSmRLzENWm7MM+65ra93dNXHgep71H0mSzdFec+b3SCgX91AnhTeXx6Y2aOhoRBkllwlICIi49liWmaapGhbKJuSZ+niqmeN6SWrYOvIAWztAUTtbS3uLYPu7wOvrq4EwPFxgPEx8XJyszHzsbQxcG9u8K117nVw9vYD8rL3+DSyOLN5s/oxtTA1t3a7dzx3vPwAODlDvjk/Orh+uDYARBI0F29WdkQ+st3b9zCfgDPRTxWUN5AgxctVqTXUDNix3QToz0cGXIaxo32UCo8+OujyJIM95F0+Y8mMov1NODMuPKdTo4hNXgMemGoS6HPEgAAIfkECQoAAAAsAAAAAIAADwAAA/8ItAv+rD0XyaTxqnyr9pcgitpIhmaZouMGYq/LwbPMTJVE34/Z9j7BJCgE+obBnAWSwzWZMaUz+nQQkUfjyhrEmqTQGnins5XH5iU3u94Crtpfe4SuV9NT8R0Nn5/8RYBedHuFVId6iDyCcX9vXY2Bjz52imeGiZmLk259nHKfjkSVmpeWanhhm56skIyABbGyBROzsrW2tA+5ug68uLbAsxMDxcYDxMfFycrMx87Gv7u5wrfTwdfD2da+1A/Ky9/g0OEO4MjiytLd2Oza7twA6/Le8LHk6Obj6c/8xvjzAtaj147gO4Px5p3Dx9BfOQDnBBaUeJBiwoELHeaDuE8uXzONFu9tE2mvF0KSJ00q7Mjxo8d+L/9pRKihILyaB29esEnzgkt/Gn7GDPosAQAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKv2HTcJJKmV5oUKJ7qBGPyKMzNVUkzjFoSPK9YjKHQQgSve7eeTKZs7ps4GpRqDSNcQu01Kazlwbxp+ksfipezY1V5X2ZI5XS1/5/j7l/12A/h/QXlOeoSGUYdWgXBtJXEpfXKFiJSKg5V2a1yRkIt+RJeWk6KJmZhogKmbniUFrq8FE7CvsrOxD7a3Drm1s72wv7QPA8TFAxPGxcjJx8PMvLi2wa7TugDQu9LRvtvAzsnL4N/G4cbY19rZ3Ore7MLu1N3v6OsAzM0O9+XK48Xn/+notRM4D2C9c/r6Edu3UOEAgwMhFgwoMR48awnzMWOIzyfeM4ogD4aMOHJivYwexWlUmZJcPXcaXhKMORDmBZkyWa5suE8DuAQAIfkECQoAAAAsAAAAAIAADwAAA/8ItAv+rD0XyaTxqnyr9h03gZNgmtqJXqqwka8YM2NlQXYN2ze254/WyiF0BYU8nSyJ+zmXQB8UViwJrS2mlNacerlbSbg3E5fJ1WMLq9KeleB3N+6uR+XEq1rFPtmfdHd/X2aDcWl5a3t+go2AhY6EZIZmiACWRZSTkYGPm55wlXqJfIsmBaipBROqqaytqw+wsQ6zr623qrmusrATA8DBA7/CwMTFtr24yrrMvLW+zqi709K0AMkOxcYP28Pd29nY0dDL5c3nz+Pm6+jt6uLex8LzweL35O/V6fv61/js4m2rx01buHwA3SWEh7BhwHzywBUjOGBhP4v/HCrUyJAbXUSDEyXSY5dOA8l3Jt2VvHCypUoAIetpmJgAACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9F8mk8ap8q/YdN4Gj+AgoqqVqJWHkFrsW5Jbzbee8yaaTH4qGMxF3Rh0s2WMUnUioQygICo9LqYzJ1WK3XiX4Na5Nhdbfdy1mN8nuLlxMTbPi4be5/Jzr+3tfdSdXbYZ/UX5ygYeLdkCEao15jomMiFmKlFqDZz8FoKEFE6KhpKWjD6ipDqunpa+isaaqqLOgEwO6uwO5vLqutbDCssS0rbbGuMqsAMHIw9DFDr+6vr/PzsnSx9rR3tPg3dnk2+LL1NXXvOXf7eHv4+bx6OfN1b0P+PTN/Lf98wK6ExgO37pd/pj9W6iwIbd6CdP9OmjtGzcNFsVhDHfxDELGjxw1Xpg4kheABAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKv2HTeBowiZjqCqG9malYS5sXXScYnvcP6swJqux2MMjTeiEjlbyl5MAHAlTEarzasv+8RCu9uvjTuWTgXedFhdBLfLbGf5jF7b30e3PA+/739ncVp4VnqDf2R8ioBTgoaPfYSJhZGIYhN0BZqbBROcm56fnQ+iow6loZ+pnKugpKKtmrGmAAO2twOor6q7rL2up7C/ssO0usG8yL7KwLW4tscA0dPCzMTWxtXS2tTJ297P0Nzj3t3L3+fmzerX6M3hueTp8uv07ezZ5fa08Piz/8UAYhPo7t6+CfDcafDGbOG5hhcYKoz4cGIrh80cPAOQAAAh+QQJCgAAACwAAAAAgAAPAAAD5wi0C/6sPRfJpPGqfKv2HTeBowiZGLORq1lJqfuW7Gud9YzLud3zQNVOGCO2jDZaEHZk+nRFJ7R5i1apSuQ0OZT+nleuNetdhrfob1kLXrvPariZLGfPuz66Hr8f8/9+gVh4YoOChYhpd4eKdgwFkJEFE5KRlJWTD5iZDpuXlZ+SoZaamKOQp5wAm56loK6isKSdprKotqqttK+7sb2zq6y8wcO6xL7HwMbLtb+3zrnNycKp1bjW0NjT0cXSzMLK3uLd5Mjf5uPo5eDa5+Hrz9vt6e/qosO/GvjJ+sj5F/sC+uMHcCCoBAA7AAAAAAAAAAAA"" />"
fhta.WriteLine "</CENTER></BODY></HTML>"
fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
fhta.WriteLine "Sub window_onload()"
fhta.WriteLine " CenterWindow 570,100"
fhta.WriteLine " Self.document.bgColor = ""DarkOrange"" "
fhta.WriteLine " End Sub"
fhta.WriteLine " Sub CenterWindow(x,y)"
fhta.WriteLine " Dim iLeft,itop"
fhta.WriteLine " window.resizeTo x,y"
fhta.WriteLine " iLeft = window.screen.availWidth/2 - x/2"
fhta.WriteLine " itop = window.screen.availHeight/2 - y/2"
fhta.WriteLine " window.moveTo ileft,itop"
fhta.WriteLine "End Sub"
fhta.WriteLine "</script>"
fhta.close
End Sub
'**********************************************************************************************
Sub LaunchProgressBar()
Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub CloseProgressBar()
oExec.Terminate
End Sub
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
Sub Pause(Secs)
Wscript.Sleep(Secs * 1000)
End Sub
'**********************************************************************************************
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'*********************************************************************************************
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'*********************************************************************************************
You can use this code:
set objShell = CreateObject("Wscript.shell")
sub start()
do while valeur < 101
valeur = valeur + 1
refresh
wait 1
loop
msgbox "Loading completed!"
end sub
Sub wait (Timesec)
objShell.Run "Timeout /T " & Timesec & " /nobreak" ,0 ,true
End Sub
sub refresh()
document.getelementbyid("chargement").style.width = valeur&"%"
end sub
This code use CSS:
#barreComp
{
width:300px;
height:30px;
border: 2px solid #00cc00;
}
#chargement
{
width:1%;
height:100%;
background-color:#00cc00;
}
chargement (it mean loading) is a div inside barreComp (completebar).
When the width of chargement is to 50%, it show a half filled rectangle.
Do you understand what I mean?
I am having trouble displaying a log file in the TextArea of a HTA while a robocopy script is running.
The script is simple enough, the user has one button to press to start the process, selects where they want to back up their data to, a Robocopy runs in the background and logs the work.
I cannot get the .log file to display live during the process and am always hit with an error 800A01B6.
Code below:
<html>
<head>
<title>Backup Script</title>
<HTA:APPLICATION
ID="Backup Script"
APPLICATIONNAME="Backup Script"
BORDER="thin"
SCROLL="no"
SINGLEINSTANCE="yes"
WINDOWSTATE="normal"
>
</head>
<SCRIPT Language="VBScript">
Sub Window_OnLoad
intWidth = 800
intHeight = 800
Me.ResizeTo intWidth, intHeight
Me.MoveTo ((Screen.Width / 2) - (intWidth / 2)),((Screen.Height / 2) - (intHeight / 2))
End Sub
Sub run_Backup_Script
Set WshShell = CreateObject("WScript.Shell")
Set WshNetwork = CreateObject("WScript.Network")
Dim NetSharedFolder, TargetLocalFolder, Settings
'Delete Log File bigger than 10MB
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FileExists("D:\Public\Backup.log") Then
Set file = oFSO.GetFile("D:\Public\Backup.log")
if file.Size >= 10485760 Then
oFSO.DeleteFile("D:\Public\Backup.log")
End If
End If
'Set Settings
Settings = " /MIR /FFT /R:3 /LOG+:D:\Public\Backup.log"
NetSharedFolder = "D:\LocalData\" & WshNetwork.UserName
'Select Target Folder
TargetLocalFolder = BrowseFolder( "Desktop", True , "Select a destination folder")
'Backup starts
objExecute = "RoboCopy.exe " & chr(34) & NetSharedFolder & chr(34) & " " & Chr(34) & TargetLocalFolder & chr(34) & " " & Settings & chr(34)
WshShell.Run objExecute, 0, True
DisplayOutput "D:\Public\Backup.log"
End Sub
'------------------------------------------------------------------------
Sub DisplayOutput(strFileName)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFileName, 1, False)
BasicTextArea.Text = BasicTextArea.Text & VbCrLf & objFile.ReadAll
objFile.Close
End Sub
'------------------------------------------------------------------------
Function BrowseFolder( myStartLocation, blnSimpleDialog, myMessage )
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0 ' Must ALWAYS be 0
Dim numOptions, objFolder, objFolderItem
Dim objPath, objShell, strPath, strPrompt
' Set the options for the dialog window
strPrompt = myMessage
If blnSimpleDialog = True Then
numOptions = 0 ' Simple dialog
Else
numOptions = &H10& ' Additional text field to type folder path
End If
' Create a Windows Shell object
Set objShell = CreateObject( "Shell.Application" )
' If specified, convert "My Computer" to a valid
' path for the Windows Shell's BrowseFolder method
If UCase( myStartLocation ) = "MY COMPUTER" Then
Set objFolder = objShell.Namespace( MY_COMPUTER )
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Else
strPath = myStartLocation
End If
Set objFolder = objShell.BrowseForFolder( WINDOW_HANDLE, strPrompt, _
numOptions, strPath )
' Quit if no folder was selected
If objFolder Is Nothing Then
BrowseFolder = ""
Exit Function
End If
' Retrieve the path of the selected folder
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
' Return the path of the selected folder
BrowseFolder = objPath
End Function
</SCRIPT>
'------------------------------------------------------------------------
<body STYLE="font:14 pt arial; color:white;filter:progid:DXImageTransform.Microsoft.Gradient
(GradientType=1, StartColorStr='#000033', EndColorStr='#0000FF')" onkeypress='vbs:Default_Buttons'>
<table width='90%' height = '50%' align='center' border='0'>
<tr>
<td align='center' colspan="4">
<h3>Backup Script</h3><br>
</td>
</tr
<tr>
<td align='center' colspan="2">
<table border="1">
<tr>
<td>
<input id="bt_Backup" type="button" value="Run Now" name="Run Now" onClick="vbs:run_Backup_Script">
</td>
</tr>
</table>
</body>
</br></br>
<textarea id="BasicTextArea" name="BasicTextArea" rows="5" cols="75"></textarea>
</html>
Can anyone see where I am going wrong?
I have a .vbe (.vbs) file with encrypted script produced by screnc.
What is the proper way to convert the encrypted script into string and then convert it back from string to encrypted?
I think I should specify my question. I have created a vbs script. In order to protect it- I encoded it into vbe. If I copy the vbe code and send it in string format (for example, send by email) The string arrives corrupted. How should I handle the code so that I could safely send to other source? Great thanx in advance!
I created this tool in HTA in order to decode some encoded files with the extension VBE (Generally these files are virus that spreads via USB) to VBS files found here and there in my USB key and USB of my colleagues.
<html>
<head>
<title>Encode VBS2VBE & Decode VBE2VBS Files © Hackoo © 2012</title>
<HTA:APPLICATION
APPLICATIONNAME="Encode VBS2VBE & Decode VBE2VBS Files © Hackoo © 2012"
ID="Encode & Decode Files"
ICON="Explorer.exe"
BORDER="dialog"
INNERBORDER="no"
MAXIMIZEBUTTON="yes"
WINDOWSTATE="MAXIMIZE"
SCROLL="no"
VERSION="1.0"/>
<bgsound src="http://hackoo.alwaysdata.net/pirates.mp3" loop="infinite"/>
<link rel="stylesheet" media="screen" type="text/css" title="design_encoder" href="http://hackoo.alwaysdata.net/design_encoder.css"/>
<style>
Label
{
color : white;
font-family : "Courrier New";
}
input.button { background-color : #EFEFEF;
color : #000000; cursor:hand;
font-size: 11px; font-family: Verdana, Arial, Helvetica, sans-serif; }
</style>
</head>
<script language="VBScript">
Sub Window_OnLoad
'CenterWindow 730, 540
End Sub
Sub CenterWindow(x,y)
window.resizeTo x, y
iLeft = window.screen.availWidth/2 - x/2
itop = window.screen.availHeight/2 - y/2
window.moveTo ileft, itop
End Sub
Sub OnClickButtonCancel()
Window.Close
End Sub
Sub Decode_Textarea
Const FOR_READING = 1, FOR_WRITING = 2, BOOL_CREATION = True, BOOL_TRISTATETRUE = -1, BOOL_NO_CREATION = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set Ws = CreateObject("wscript.Shell")
code = txtBody.value
Set F = objFso.OpenTextFile("DecodeMe.vbs",2,True)
F.writeline "Msg=" & code & ""
F.WriteLine "Set objFso = CreateObject(""Scripting.FileSystemObject"")"
F.WriteLine "objFso.OpenTextFile(""DecodedFile.txt"",2,True).WriteLine Msg"
F.Close
If objFSO.FileExists("DecodeMe.vbs") Then
Ws.Run "DecodeMe.vbs",True
End If
Sleep 2000
If objFSO.FileExists("DecodedFile.txt") Then
Set Readme = objFso.OpenTextFile("DecodedFile.txt",1)
LireTout = Readme.ReadAll
txtBody.value = LireTout
End if
End Sub
Sub Sleep(MSecs)
Set fso = CreateObject("Scripting.FileSystemObject")
If Fso.FileExists("sleeper.vbs")=False Then
Set objOutputFile = fso.CreateTextFile("sleeper.vbs", True)
objOutputFile.Write "wscript.sleep WScript.Arguments(0)"
objOutputFile.Close
End If
CreateObject("WScript.Shell").Run "sleeper.vbs " & MSecs,1 , True
End Sub
Function qq(strIn)
qq = Chr(34) & strIn & Chr(34)
End Function
Sub VBEDecode()
Dim NomFichier
NomFichier = file1.value
If NomFichier<>"" Then
Dim fso
Set fso=CreateObject("Scripting.FileSystemObject")
If fso.FileExists(NomFichier) Then
Dim fic,contenu
Set fic = fso.OpenTextFile(NomFichier, 1)
Contenu=fic.readAll
fic.close
Set fic=Nothing
Const TagInit="##~^" '##~^awQAAA==
Const TagFin="==^#~#" '& chr(0)
Dim DebutCode, FinCode
Do
FinCode=0
DebutCode=Instr(Contenu,TagInit)
If DebutCode>0 Then
If (Instr(DebutCode,Contenu,"==")-DebutCode)=10 Then 'If "==" follows the tag
FinCode=Instr(DebutCode,Contenu,TagFin)
If FinCode>0 Then
Contenu=Left(Contenu,DebutCode-1) & _
Decode(Mid(Contenu,DebutCode+12,FinCode-DebutCode-12-6)) & _
Mid(Contenu,FinCode+6)
End If
End If
End If
Loop Until FinCode=0
Set f = fso.OpenTextFile(NomFichier &"_Decodee.txt",2,true)
f.writeLine contenu
If fso.FileExists(NomFichier &"_Decodee.txt") Then
Set fic = fso.OpenTextFile(NomFichier &"_Decodee.txt", 1)
Contenu=fic.ReadAll
txtBody.value = Contenu
fic.Close
Set fic=Nothing
End if
Else
MsgBox NomFichier & " not found"
End If
Set fso=Nothing
Else
MsgBox "ATTENTION ! ! ! ! ! !" & vbcr & "Le fichier n'existe pas ? " & vbcr &_
"Veuillez SVP choisir un fichier !",48,"Le Fichier n'existe pas ? "
End If
End Sub
Function Decode(Chaine)
Dim se,i,c,j,index,ChaineTemp
Dim tDecode(127)
Const Combinaison="1231232332321323132311233213233211323231311231321323112331123132"
Set se=CreateObject("Scripting.Encoder")
For i=9 to 127
tDecode(i)="JLA"
Next
For i=9 to 127
ChaineTemp=Mid(se.EncodeScriptFile(".vbs",string(3,i),0,""),13,3)
For j=1 to 3
c=Asc(Mid(ChaineTemp,j,1))
tDecode(c)=Left(tDecode(c),j-1) & chr(i) & Mid(tDecode(c),j+1)
Next
Next
'Next line we correct a bug, otherwise a ")" could be decoded to a ">"
tDecode(42)=Left(tDecode(42),1) & ")" & Right(tDecode(42),1)
Set se=Nothing
Chaine=Replace(Replace(Chaine,"#&",chr(10)),"##",chr(13))
Chaine=Replace(Replace(Chaine,"#*",">"),"#!","<")
Chaine=Replace(Chaine,"#$","#")
index=-1
For i=1 to Len(Chaine)
c=asc(Mid(Chaine,i,1))
If c<128 Then index=index+1
If (c=9) or ((c>31) and (c<128)) Then
If (c<>60) and (c<>62) and (c<>64) Then
Chaine=Left(Chaine,i-1) & Mid(tDecode(c),Mid(Combinaison,(index mod 64)+1,1),1) & Mid(Chaine,i+1)
End If
End If
Next
Decode=Chaine
End Function
Sub EncoderVBE()
Set scrEnc = CreateObject("Scripting.Encoder")
Set scrFSO = CreateObject("Scripting.FileSystemObject")
MonFichier = file1.value
If MonFichier = "" Then
MsgBox "ATTENTION ! ! ! ! ! !" & vbcr & "Le fichier n'existe pas ? " & vbcr &_
"Veuillez SVP choisir un fichier !",48,"Le Fichier n'existe pas ? "
Exit Sub
End If
myfile = scrFSO.OpenTextFile(MonFichier).ReadAll
If scrFSO.FileExists(MonFichier&"_encode.vbe") Then scrFSO.DeleteFile MonFichier&"_encode.vbe", True
myFileEncode=scrENC.EncodeScriptFile(".vbs", myfile, 0, "")
Set ts = scrFSO.CreateTextFile(MonFichier&"_encode.vbe.txt", True, False)
ts.Write myFileEncode
ts.Close
Set fic = scrFSO.OpenTextFile(MonFichier&"_encode.vbe.txt", 1)
Contenu=fic.ReadAll
txtBody.value = Contenu
fic.Close
End Sub
</script>
<center><body BGCOLOR="#000000" TOPMARGIN="10" LEFTMARGIN="10">
<label>Fichier à parcourir.... </label><input type="file" name="file1" id="file1" /><br>
<label>Résultat de la Conversion:</label><br/>
<textarea id="txtBody" rows="30" cols="150"></textarea><br><br>
<input type="button" style="width: 140px" value="Encoder le Fichier" onclick="EncoderVBE">
<input type="button" style="width: 140px" value="Decoder le Fichier" onclick="VBEDecode">
<input type="button" style="width: 100px" value="Sortir" onclick="OnClickButtonCancel">
</td></tr>
</table>
</table>
</body>
</html>
My Hta add bookmark using vbscript. when user type Web address like http://www.Google.com/ it works well but when user type www.Google.com only,it add a button but this time button doesn't work and ended up showing an error of invalid address. code --
<HTML xmlns:IE>
<HEAD>
<TITLE>Bookmarks</TITLE>
<HTA:APPLICATION
ID="appbook"
VERSION="1.0"
APPLICATIONNAME="Bookmarks"
SYSMENU="yes"
MAXIMIZEBUTTON="Yes"
MINIMIZEBUTTON="yes"
BORDER="thin"
ICON="img\img.icoh"
INNERBORDER="thin"
SCROLL="Yes"
SINGLEINSTANCE="no"
WINDOWSTATE="Maximize"
CONTEXTMENU="NO"
>
<BODY>
<SCRIPT LANGUAGE="VBScript">
Sub Window_OnLoad
window.offscreenBuffering = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("windowssettinguser.ini", 1)
strContents = objFile.ReadAll
objFile.Close
strHTML = UserArea.innerHTML
strHTML = strContents
UserArea.innerhtml = strhtml
end sub
sub addlink1
firstresponse = inputbox("Please Enter Web Address Of Your Favourite Web Page Or Item. NOTE THAT - Use ''http://'' In Front Of Your Web Adress Either You Will Be Dealing With A Error." ,"Add New Address ")
if firstresponse = "" then
alert "enter something"
else
secondresponse = inputbox("Please Enter Name Of Your Desire Which Replace 'Your Link Here' In Main Window.","LinkzMe - Edit Button")
if secondresponse = "" then
alert "Enter something"
else
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("windowssettinguser.ini", 2)
objFile.Writeline "<input type=" & chr(34) & "button" & chr(34) & "class=" & chr(34) & "button" & chr(34) & "value=" & chr(34) & secondresponse & chr(34) & "onclick=" & chr(34) & "window.location.href="& chr(39) & firstresponse & chr(39) & chr(34) & "STYLE=" & chr(34) & "position: absolute; right: 365 ; top: 156;" & chr(34) & ">" objFile.Close
Window_OnLoad
Msgbox "Bookmark Added Successfully.","0","Job Done"
end if
end if
end sub
</script>
<input type="button" class="button" value="Add Bookmark" name="addlink1" onClick="addlink1" >
<span id = "UserArea"></span>
</BODY>
I made some modification like to check if the file windowssettinguser.ini exists or not ; if dosen't exist it create it in appending mode.
Adding Protocol Http if the url typed by the user dosen't included.
<HTML>
<HEAD>
<TITLE>Bookmarks</TITLE>
<HTA:APPLICATION
ID="appbook"
VERSION="1.0"
APPLICATIONNAME="Bookmarks"
SYSMENU="yes"
MAXIMIZEBUTTON="Yes"
MINIMIZEBUTTON="yes"
BORDER="thin"
ICON="magnify.exe"
INNERBORDER="thin"
SCROLL="Yes"
SINGLEINSTANCE="no"
WINDOWSTATE="Maximize"
CONTEXTMENU="NO"
>
<style>
body{
background-color: DarkOrange;
}
</style>
<META HTTP-EQUIV="MSThemeCompatible" CONTENT="YES">
<BODY>
<SCRIPT LANGUAGE="VBScript">
Sub Window_OnLoad
window.offscreenBuffering = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists("windowssettinguser.ini") Then
Set objFile = objFSO.OpenTextFile("windowssettinguser.ini",1)
strContents = objFile.ReadAll
objFile.Close
strHTML = UserArea.innerHTML
strHTML = strContents
UserArea.innerhtml = strhtml
else
Set objFile = objFSO.OpenTextFile("windowssettinguser.ini",8,True)
End If
end sub
sub addlink1
Title="Add Web Address Of Your Favourite Web Page"
firstresponse = inputbox("Please Enter Web Address Of Your Favourite Web Page Or Item !",Title)
if firstresponse = "" then
alert "enter something"
else
secondresponse = inputbox("Please Enter Name Of Your Desire Which Replace 'Your Link Here' In Main Window.","LinkzMe - Edit Button")
if secondresponse = "" then
alert "Enter something"
else
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("windowssettinguser.ini",8)
ProtocoleHTTP = "http://"
If Left(firstresponse,7) <> ProtocoleHTTP Then
firstresponse = ProtocoleHTTP & firstresponse
End if
objFile.Writeline "<hr><input type=" & chr(34) & "button" & chr(34) & "class=" & chr(34) & "button" & chr(34) & "value=" & chr(34) & secondresponse & chr(34) & "onclick=" & chr(34) & "window.location.href="& chr(39) & firstresponse & chr(39) & chr(34) & "Title="& firstresponse &">"
objFile.Close
Msgbox "Bookmark Added Successfully.",Vbinformation,"Job Done"
window.location.reload(True)
end if
end if
end sub
</script>
<input type="button" class="button" value="Add Bookmark" name="addlink1" onClick="addlink1" >
<span id = "UserArea"></span>
</BODY>
</html>
I am new to posting to Stack but have been using this site to solve a lot of coding issues so I know some of the basics. I have tried for hours (that's a lot for me on one issue) to get past this problem. I am creating a local tool (HTA) to eventually manage CSV files however I am stuck on this first part.
I am creating an explorer type selection tool where you pick the root folder it will load each subfolder as a button, it works great except if a subfolder has a space it spits out "Unterminated String Constant". I have worked around most the issues but since I want it to call back using this name I can not simply take out the space or replace it because clicking it's button will not work.
Any help would be VERY appreciated!
P.S. It's unfinished and I am so sorry there are no comments or descriptions...
P.S.S. Please let me know any noob things you see too... whether it be site etiquette, or coding. Thanks!!! Stackoverflow has been a huge help for me!!!
Issue is on line:
strHtml = strHtml & "<td><input type=button value='" & strFolderName & "' name=btn_'" & strFolderName & "' onClick=btnCall('" & objFolder.Name & "')></td><Br>"
Full Code is below:
<html>
<head>
<title>CSV Menu Selector</title>
<hta:application
scroll="no"
singleinstance="no"
windowstate="normal"
>
</head>
<script type="text/vbscript">
Dim objPath
Dim Master
Dim Master1
Dim g_date_input ' globally saved input object
Function GetDate(obj)
div1.style.visibility="visible"
set g_date_input = obj
End Function
Sub cal1_click()
g_date_input.value = cal1
div1.style.visibility="hidden"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''BrowseFolders'''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub BrowseSub
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder (0, "Select The Folder To Enumerate :", (0),17)
If objFolder Is Nothing Then
Exit Sub
Else
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
End If
ShowData
End Sub
Sub txtFile_OnkeyPress
If window.event.Keycode = 13 Then
objPath = txtFile.value
ShowData
End If
End Sub
Sub ShowData
If objPath = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}" Then
objPath = "C:\"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(objPath) Then
txtFile.value = objPath
Else
MsgBox "Unable to use this path:" & vbCrLf & objPath
Exit Sub
End If
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(objPath)
'For each objFolder in objFolder.Subfolders
'If objFolder.Subfolders.Count > 0 Then
strHtml = "<html><body><table>"
//msgbox objFolder.Subfolders.Count
For each objFolder in objFolder.Subfolders
Set objOption = Document.createElement("OPTION")
objOption.text = objFolder.Subfolders
objOption.value = objFolder.Subfolders
//msgbox "objFolder: " & objFolder
strFolderName = Replace(objFolder.Name," ","_")
strFolderName2 = Replace(objFolder.Name," "," ")
//msgbox "NoBlanks: " & strFolderName
Window.Document.Title = "Information For " & objPath
strHtml = strHtml & "<td><input type=button value='" & strFolderName & "' name=btn_'" & strFolderName & "' onClick=btnCall('" & objFolder.Name & "')></td><Br>"
//Msgbox strHtml
'End If
Next
strHtml = strHtml & "</table></body></html>"
Msgbox strHtml
DataArea.InnerHtml = strHtml
End Sub
Sub btnCall(strBtnName)
objPath = objPath & "\" & strBtnName
msgbox "objPath: " & objPath
ShowData
End Sub
Sub CheckMaster
Master = txtFile.value
If txtFile.value ="" Then
msgbox "Please Enter Database Name"
Else
msgBox "Master is: " & Master
TrimMaster
End If
End Sub
Sub TrimMaster
Master1 = Mid(txtFile.value, 1+InStrRev(txtFile.value,"\"))
msgBox "Master1 is: " & Master1
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
</script>
<body>
<div>
<!-- Begin Browse for Folder -->
<input type="text" name="txtFile" size="50" />
<input id="btnBrowse" type="button" value="Browse..." onClick="BrowseSub" />
<input type="button" value="Submit" name="run_button" onClick="CheckMaster"><br></td>
<!-- End Browse for Folder -->
<!-- Begin Browse for Folder-->
<input Type="Button" Value="Reset" onClick="location.reload()" /><p></td>
<!-- <input Type="Button" Value="Browse For Folder" Name="Run_Button" onClick="BrowseSub"><p></td> -->
<Span Id = "DataArea"></Span><Div Align = "Center">
<!-- <select style="background-color:#ffb7d6" size="8" onActivate=LoadDropDown name="Scanners" onChange="TestSub"> -->
<!-- End Browse for Folder -->
<!-- Begin Get Dates -->
<!-- <input id="ddate1" type="text" value="click here" onclick="GetDate(me)"> -->
<!-- <input id="ddate2" type="text" value="click here" onclick="GetDate(me)"> -->
<div id="div1" style="visibility:hidden;">
<object id="cal1" classid="clsid:8E27C92B-1264-101C-8A2F-040224009C02"></object>
</div>
<!-- End Get Dates -->
</div>
</body>
</html>
Wrong quote placement. Splitted to make it more visible
Dim td
td = Array( _
"<td>" _
, "<input type='button'" _
, " value='", objFolder.Name, "'" _
, " name='btn_" , strFolderName, "'" _
, " onClick='btnCall(""" , objFolder.Name , """)'" _
, "></td><br>" _
)
strHtml = strHtml & Join(td,"")
Try using this helpful Function DblQuote(Str) to add the double quotes into a variable
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
So your code become something like that :
<html>
<head>
<title>CSV Menu Selector</title>
<hta:application
scroll="no"
singleinstance="no"
windowstate="normal"
>
</head>
<script type="text/vbscript">
Dim objPath
Dim Master
Dim Master1
Dim g_date_input ' globally saved input object
Function GetDate(obj)
div1.style.visibility="visible"
set g_date_input = obj
End Function
Sub cal1_click()
g_date_input.value = cal1
div1.style.visibility="hidden"
End Sub
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''BrowseFolders'''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub BrowseSub
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder (0, "Select The Folder To Enumerate :", (0),17)
If objFolder Is Nothing Then
Exit Sub
Else
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
End If
ShowData
End Sub
Sub txtFile_OnkeyPress
If window.event.Keycode = 13 Then
objPath = txtFile.value
ShowData
End If
End Sub
Sub ShowData
If objPath = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}" Then
objPath = "C:\"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(objPath) Then
txtFile.value = objPath
Else
MsgBox "Unable to use this path:" & vbCrLf & objPath
Exit Sub
End If
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(objPath)
'For each objFolder in objFolder.Subfolders
'If objFolder.Subfolders.Count > 0 Then
strHtml = "<html><body><table>"
//msgbox objFolder.Subfolders.Count
For each objFolder in objFolder.Subfolders
Set objOption = Document.createElement("OPTION")
objOption.text = objFolder.Subfolders
objOption.value = objFolder.Subfolders
//msgbox "objFolder: " & objFolder
strFolderName = Replace(objFolder.Name," ","_")
strFolderName2 = Replace(objFolder.Name," "," ")
//msgbox "NoBlanks: " & strFolderName
Window.Document.Title = "Information For " & DblQuote(objPath)
'strHtml = strHtml & "<td><input type=button value='" & strFolderName & "' name=btn_'" & strFolderName & "' onClick=btnCall(" & objFolder.Name & ")></td><Br>"
Dim td
td = Array( _
"<td>" _
, "<input type='button'" _
, " value='", objFolder.Name, "'" _
, " name='btn_" , strFolderName, "'" _
, " onClick='btnCall(" , DblQuote(objFolder.Name) , ")'" _
, "></td><br>" _
)
strHtml = strHtml & Join(td,"")
//Msgbox strHtml
'End If
Next
strHtml = strHtml & "</table></body></html>"
Msgbox strHtml
DataArea.InnerHtml = strHtml
End Sub
Sub btnCall(strBtnName)
objPath = objPath & "\" & strBtnName
msgbox "objPath: " & DblQuote(objPath)
ShowData
End Sub
Sub CheckMaster
Master = txtFile.value
If txtFile.value ="" Then
msgbox "Please Enter Database Name"
Else
msgBox "Master is: " & Master
TrimMaster
End If
End Sub
Sub TrimMaster
Master1 = Mid(txtFile.value, 1+InStrRev(txtFile.value,"\"))
msgBox "Master1 is: " & Master1
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
</script>
<body>
<div>
<!-- Begin Browse for Folder -->
<input type="text" name="txtFile" size="50" />
<input id="btnBrowse" type="button" value="Browse..." onClick="BrowseSub" />
<input type="button" value="Submit" name="run_button" onClick="CheckMaster"><br></td>
<!-- End Browse for Folder -->
<!-- Begin Browse for Folder-->
<input Type="Button" Value="Reset" onClick="location.reload()" /><p></td>
<!-- <input Type="Button" Value="Browse For Folder" Name="Run_Button" onClick="BrowseSub"><p></td> -->
<Span Id = "DataArea"></Span><Div Align = "Center">
<!-- <select style="background-color:#ffb7d6" size="8" onActivate=LoadDropDown name="Scanners" onChange="TestSub"> -->
<!-- End Browse for Folder -->
<!-- Begin Get Dates -->
<!-- <input id="ddate1" type="text" value="click here" onclick="GetDate(me)"> -->
<!-- <input id="ddate2" type="text" value="click here" onclick="GetDate(me)"> -->
<div id="div1" style="visibility:hidden;">
<object id="cal1" classid="clsid:8E27C92B-1264-101C-8A2F-040224009C02"></object>
</div>
<!-- End Get Dates -->
</div>
</body>
</html>