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>
Related
Scenario: pull the information from a running HTA and update an INPUT field with the information on a updated every 1 second. The concept was to use the INPUT field as a sort of progress bar while working with thousands of files (like 12300+ files) so that it did not just sit there and do nothing for near half hour! The end result does not error, but the INPUT field remains empty.
Here is my code (I know it is "dirty" but I was using only for a test):
<meta http-equiv='X-UA-Compatible' content='IE=8; IE=7' />
<html>
<head>
<hta:application id=oHTA
border=none
caption=no
contextmenu=no
innerborder=yes
scroll=no
showintaskbar=no
/>
<style>
body{
padding: 0;
margin: 0;
background-color: #000;
display: flex;
align-items: center;
justify-content: center;
}
img{width:100%;height:100%;left:0;top:0;position:absolute;}
div{z-index:1;position:absolute;color:black;top:80%;width:100%;}
input{width:20%;color:red;background:transparent;}
</style>
</head>
<body style='text-align:center;background:black;' >
<div>
<button id=click>Click</button><br>
</div>
<input type=text id=myinput />
<script language="vbscript">
mm=self.location.pathname
curdir = split(mm,"\")
for x =0 to ubound(curdir)
settimeout "updater(curdir(x))",10000
next
sub click_onclick
self.close
end sub
function updater(xx)
set ii = document.getelementbyid("myinput")
ii.value=xx
end function
</script>
As LesFerch had mentioned, I did end up showing the file name that is being processed as well as a functional progress bar. There is too much code to enter the entire HTA contents here but this would give you a decent idea. The whole code is over 1000 lines as I included a Base64 encoded image. Essentially it was a test to rename mp3 files as such: find an entry of ", The" or ", A", remove said entry, add "The " or "A " to the beginning of the respective section whether it be artist or title. As it I have over 14000 MP3s, the code I originally made which worked very well, left the end user (in this case me!) wondering if it was still running. Today, that question is answered! The code is still ugly and I am sure it could be relieved of alot of dead space, but I am proud.
<body style='text-align:center;background:black;'>
<input type=text id="myinput" value="" />
<div style="width:100%;top:10px;text-align:center;" id="myDiv2"></div>
<div id="myDiv" style="font-size:32px;">
</div>
<div style="top:10%;left:0;width:100%;"><h2>TheA: The File Fixer</h2></div>
<button id="myButton" onclick="killvid()" >Close</button>
<button id="myAbout" onclick="bignews()" style="left:10%;">About</button>
<button id="myStart" onclick="startproc()" style="left:43%;">Start</button>
function myTime(xt)
set ws = createobject("wscript.shell")
xtr=0
do until xtr > xt
xtr = xtr+1
ws.Run "ping 127.0.0.1 -n 1", 0, true
loop
end function
function updater(xx,yy)
set ii = document.getelementbyid("myinput")
if len(ii.value) < 70 then
ii.value= ii.value & "|"
else
ii.value =""
end if
myTime(.25)
end function
function startproc()
window.moveto -19999, -19999
set s = document.getelementsbytagname("BUTTON")
for each b in s
b.style.display = "none"
next
set s = nothing
on error resume next
str = document.location.pathname
set ws = createobject("wscript.shell")
set fs = createobject("scripting.filesystemobject")
'Open the BrowseForFolder dialog
Set a2 = sa.BrowseForFolder( 0, "Select Folder",1,&h11&)
sp = a2.Self.Path
window.moveto screen.width / 2 - 900, screen.height /2 - 500
if err.number>0 then
set mb = document.getelementbyid("myButton")
set md = document.getelementbyid("myDiv")
md.innertext="Nothing ventured, Nothing gained!" &vbcrlf & "Please exit this window!"
mb.style.display="block"
exit function
'more of the function excerpted
if bfn <> dd then
fs.copyfile file.path, replace(file.path,bfn,dd),1
rrr = rrr+1
if instr(bfn,rr) then
fs.deletefile file.path
md.innertext = "Renaming " & bfn & " to " &vbcrlf & _
dd & vbcrlf & "Processing " & dtx & " files." & vbcrlf &_
"Please wait..."
elseif instr(bfn,ss) then
fs.deletefile file.path
dtx = dtx-1
md.innertext = "Renaming " & bfn & " to " &vbcrlf & _
dd & vbcrlf & "Processing " & dtx & " files." & vbcrlf &_
"Please wait..."
END IF
updater bfn,dd
end if
end function
I am trying to make multiple inputbox in one userform using vbscript instead of displaying one inputbox at a time i want to show multiple inputbox at once and then take entry from all of them but was unable to find any solution on internet too.
In my code second input box is coming after taking input from first inputbox and vice versa instead i want to take all the inputs at once using vbscript only not vba
sInput = InputBox("Enter your name")
MsgBox ("You entered:" & sInput)
sInput1 = InputBox("Enter your Age")
MsgBox ("You entered:" & sInput1)
sInput2 = InputBox("Enter email id you want to send")
sInput3 = InputBox("Enter Subject")
sInput4 = InputBox("Enter Email Body")
I found a vbscript code from #omegastripes multiline_inputbox_via_hta.vbs
I don't know if this answer can give you an idea or not?
dim completed
msgbox inputboxml("Enter text:", "Multiline inputbox via HTA", "Enter your name : " & vbcrlf & "Enter your Age : " & vbcrlf &_
"Enter email id you want to send : " & vbcrlf & "Enter Subject : " & vbcrlf & "Enter Email Body : " )
function inputboxml(prompt, title, defval)
set window = createwindow()
completed = 0
defval = replace(replace(replace(defval, "&", "&"), "<", "<"), ">", ">")
with window
with .document
.title = title
.body.style.background = "buttonface"
.body.style.fontfamily = "consolas, courier new"
.body.style.fontsize = "8pt"
.body.innerhtml = "<div><center><nobr>" & prompt & "</nobr><br><br></center><textarea id='hta_textarea' style='font-family: consolas, courier new; width: 100%; height: 400px;'>" & defval & "</textarea><br><button id='hta_cancel' style='font-family: consolas, courier new; width: 85px; margin: 10px; padding: 3px; float: right;'>Cancel</button><button id='hta_ok' style='font-family: consolas, courier new; width: 85px; margin: 10px; padding: 3px; float: right;'>OK</button></div>"
end with
.resizeto 550, 550
.moveto 100, 100
end with
window.hta_textarea.focus
set window.hta_cancel.onclick = getref("hta_cancel")
set window.hta_ok.onclick = getref("hta_ok")
set window.document.body.onunload = getref("hta_onunload")
do until completed > 0
wscript.sleep 10
loop
select case completed
case 1
inputboxml = ""
case 2
inputboxml = ""
window.close
case 3
inputboxml = window.hta_textarea.value
window.close
end select
end function
function createwindow()
rem source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
dim signature, shellwnd, proc
on error resume next
signature = left(createobject("Scriptlet.TypeLib").guid, 38)
do
set proc = createobject("WScript.Shell").exec("mshta ""about:<head><script>moveTo(-32000,-32000);</script><hta:application id=app border=dialog minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=yes innerborder=no icon=""%windir%\system32\notepad.exe""/><object id='shellwindow' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shellwindow.putproperty('" & signature & "',document.parentWindow);</script></head>""")
do
if proc.status > 0 then exit do
for each shellwnd in createobject("Shell.Application").windows
set createwindow = shellwnd.getproperty(signature)
if err.number = 0 then exit function
err.clear
next
loop
loop
end function
sub hta_onunload
completed = 1
end sub
sub hta_cancel
completed = 2
end sub
sub hta_ok
completed = 3
end sub
Hello i have implemented my vbscript code in hta and it is working fine i am sharing my full code for future reference kindly paste it in notepad and save the notepad with .hta extension
(for your reference using vbscript i am trying to take input from user store it in excel with password protection and then send that excel file through outlook to the email id which user has provided --kindly note your outlook needs to be open and running before running this code and kindly provide some different excel path i have given my file path)
<HEAD>
<TITLE>Send Status of Task</TITLE>
<hta:application
applicationname="HTA Sample"
scroll="yes"
singleinstance'"yes"
>
</HEAD>
<SCRIPT language="vbscript">
Sub RunThisSubroutine
str1 = TextBox1.Value
str2 = TextBox2.Value
str3 = TextBox3.Value
str4 = TextBox4.Value
str5 = TextBox5.Value
msgBox str1 & ", " & str2 & ", " & str3 &"," & str4&"," & str5
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\saurabh.ad.sharma\Desktop\rrr.xlsx")
objExcel.Application.Visible = True
objExcel.Sheets(1).unprotect "saurabh"
Set rg = objExcel.Sheets(1).Range("A1")
lr = rg.CurrentRegion.Rows.Count
With rg
.Offset(lr, 0).Value = str1
.Offset(lr, 1).Value = str2
End With
objExcel.ActiveWorkbook.Save
objExcel.Sheets(1).protect "saurabh"
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
objMailItem.Display
strEmailAddr = str3
objMailItem.Recipients.Add strEmailAddr
objMailItem.Subject=str4
objMailItem.Body = str5
objMailItem.Attachments.Add "C:\Users\saurabh.ad.sharma\Desktop\rrr.xlsx"
objMailItem.Send
Set objMailItem = nothing
Set objOutl = nothing
End Sub
</SCRIPT>
<BODY STYLE="FONT:10 pt verdana; COLOR:black; filter:progid:DXImageTransform.Microsoft.Gradient(GradientType=0, StartColorStr='#FFCC66', EndColorStr='#FFFFFF')">
Hyper Text Applications make it easy to add user inputs: <BR>
<label for="Name ">Name:</label>
<input type="text" name="TextBox1" size="30"><BR><BR>
<label for="Age">Age :</label>
<input type="text" name="TextBox2" size="30"><BR><BR>
<label for="Send Email to">Send Email to:</label>
<input type="text" name="TextBox3" size="30" ><BR><BR>
<label for="Subject ">Subject:</label>
<input type="text" name="TextBox4" size="30" ><BR><BR>
<label for="Body">Body:</label>
<input type="text" name="TextBox5" size="30" ><BR><BR>
<input id=runbutton class= "button" type="button" value="Run" name="button1" onClick="RunThisSubroutine">
</BODY>
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.
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>