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>
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
--------------------------------
In the above a selection is made from the lower input box populated from an array. On selection the corresponding index value from a second array is copied to the clipboard. A message box is used to advise user of value copied to clipbord but this is clunky. I added a second read only input box to display this value.
<input type="text" id = "Resulta)" / style="text-align:center;" readonly style='width:160px'/ value= bOpt(isel)>
The variable bOpt(isel) is not recognised as such being treated as text despite being unquoted. is there a simple way around this?
<html>
<head>
<HTA:Application ID="HTA"
ApplicationName="ListBox"
form name="myform"
onclick = 'Selected()'
<style type="text/css"> body {overflow-y:hidden;</style>
<style type="text/css"> body {overflow-x:hidden;</style>
Border="thin"
BorderStyle="normal"
Caption="no"
:::-webkit-scrollbar {
width: 0px; /* remove scrollbar space /
background: transparent; / optional: just make scrollbar invisible /
scroll = "no"
scrollflat = "no"
Icon=""
MaximizeButton="yes"
MinimizeButton="yes"
ShowInTaskBar="yes"
SingleInstance="yes"
SysMenu="no"
Version="1.0"
WindowState="maximize"
<script type="text/vbscript">
Option Explicit
Sub Document_OnKeyUp()
intKeyCode = Window.Event.Keycode
If intKeyCode = 27 Then Window.Close
End Sub
Dim aOpt, bOpt, iSel, iOpt, sOpt, messij
Sub Window_Onload()
Const cWid = 220
Const cHei = 122
window.resizeTo cWid, cHei
window.MoveTo screen.width/1-(cWid/1),screen.height/1-((cHei/1) + 40 )
document.parentwindow.clipboardData.SetData("TEXT"),"Fred#Email.com.au"
'<script language = "vbscript" type = "text/vbscript">
aOpt = Array("Fred email",_
"Bert email",_
"Sally email",_
"David email",_
"Peter emal")
bOpt = Array("Fred#Email.com.au" , _ "Bert#Email.com.au" , _
"Sally#Email.com.au" , _
"David#Email.com.au" , _
"Peter#Email.com.au")
sOpt = "<select id='entries' style='width:160px'>"
' & "<option selected>" & document.title & "</option>"
For iOpt = 0 To UBound(aOpt)
sOpt = sOpt & "<option>" & aOpt(iOpt) & "</option>"
Next
sOpt = sOpt & "</select><p>"
document.getElementById("opts").innerHTML = sOpt
End Sub
Sub Selected()
Dim iSel
iSel = document.getElementById("entries").selectedIndex
messij = "YOU SELECTED" & chr(13) & chr(13) & " " & aopt(isel) & chr(13) & chr(13) & "WHICH CAUSED THE VALUE" _
& chr(13) & chr(13) & " " & bopt(isel) & chr(13) & chr(13) & "TO BE COPIED TO THE CLIPBOARD"
'msgbox messij
document.parentwindow.clipboardData.SetData("TEXT"),bopt(isel)
End Sub
</script>
</head>
<body>
<input type="text" id = "Resulta)" / style="text-align:center;" readonly style='width:160px'/ value= bOpt(isel)>
<body>
<body bgColor="yellow">
<center>
<span id="resulta"></span>
<span id="opts"></span>
</center>
</html>
I put this in a sub
document.getElementById("fixit").value = bopt(isel)
which accepted the variable value and I modified my original input which treated the variable name as text by removing value = parameter
<input type="text" id = "fixit" / style="text-align:center;" readonlyx style='width:160px'>
Input box now loading successfully with variable values
I found my solution in another Stackoverflow question but cannot locate it again in order to acknowledge.
I added a Dim to get the escape key to correctly quit:
Dim intKeyCode
I removed the explicit value being set for input box:
value= bOpt(isel)
I renamed the Resulta) text box to Resulta (which necessitated renaming the later span from Resulta to Resultas to avoid duplicate names).
Then, finally, I explicitly put the value into Resulta in the Sub Selected code:
resulta.value = bOpt(iSel)
I'd never seen an onClick() event added in the HTA section before.
I was looking to set time on my computer. For that I'm scripting 3 radio buttons of three different countries so that user can set the time zone by selecting one of the radio buttons.
Also please help in below error:
Set objExecObject = objShell.Exec("tzutil.exe /s """ & TimeZoneFriendlyName & "")
WScript.Echo "Setting the time zone sucessfully."
Error message
<p><b>Search <u>w</u>here</b></p>
<p><INPUT Name=tb2 TYPE=RADIO CHECKED AccessKey=w> Google <INPUT Name=tb2 TYPE=RADIO> Wikipedia <INPUT Name=tb2 TYPE=RADIO> Nethack <INPUT Name=tb2 TYPE=RADIO> MSDN <INPUT Name=tb2 TYPE=RADIO> Australia <INPUT Name=tb2 TYPE=RADIO> Maps </p>
And
Sub Search
' On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
If tb2(5).Checked=True then WshShell.Run "https://www.google.com/maps/place/" & Replace(tb1.value, " ", "+")
If tb2(4).Checked=True then WshShell.Run "https://www.google.com/search?q=" & Replace(tb1.value, " ", "+") & "&cr=countryAU"
If tb2(3).Checked=True then WshShell.Run "https://www.google.com/search?q=site:msdn.com+" & Replace(tb1.value, " ", "+")
If tb2(2).Checked=True then WshShell.Run "https://www.google.com/search?q=nethack+" & Replace(tb1.value, " ", "+")
If tb2(1).Checked=True then WshShell.Run "https://en.wikipedia.org/wiki/" & tb1.value
If tb2(0).Checked=True then WshShell.Run "https://www.google.com/search?q=" & Replace(tb1.value, " ", "+")
WshShell.RegWrite "HKCU\Software\StackOverflow\VBS\Searchterm", tb1.value & vbtab & WshShell.RegRead("HKCU\Software\StackOverflow\VBS\Searchterm")
If tb3.checked=true then window.close
End Sub
You also have got your quotes wrong. Cmd /k will allow you to see what happens in CMD, remove it once it works.
WScript.CreateObject("WScript.Shell").Run "cmd /k tzutil.exe /s """ & TimeZoneFriendlyName & """"
Here's an HTA showing radio buttons, check boxes, buttons, and shows how to implement keyboard access.
<HTML>
<HEAD><TITLE>Search</TITLE>
<HTA:APPLICATION ID="oMyApp"
APPLICATIONNAME="Search"
BORDER="normal"
BORDERSTYLE="sunken"
CONTEXTMENU="yes"
CAPTION="yes"
ICON="C:\windows\system32\shell32,-5"
SCROLL="no"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SYSMENU="yes"
WINDOWSTATE="normal"
/>
<style>
BODY {font-size :100%;font-family: Arial, Helvetica, sans-serif;color: black;
background:URL(images/watermark.gif);background-color: white;
margin-top:20pt; margin-left:40pt; margin-right:10pt ; text-align:Justify}
P {margin-left:0pt;margin-right:0pt}
</style>
<SCRIPT LANGUAGE="VBScript">
Dim Searchterm
Sub Search
' On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
If tb2(5).Checked=True then WshShell.Run "https://www.google.com/maps/place/" & Replace(tb1.value, " ", "+")
If tb2(4).Checked=True then WshShell.Run "https://www.google.com/search?q=" & Replace(tb1.value, " ", "+") & "&cr=countryAU"
If tb2(3).Checked=True then WshShell.Run "https://www.google.com/search?q=site:msdn.com+" & Replace(tb1.value, " ", "+")
If tb2(2).Checked=True then WshShell.Run "https://www.google.com/search?q=nethack+" & Replace(tb1.value, " ", "+")
If tb2(1).Checked=True then WshShell.Run "https://en.wikipedia.org/wiki/" & tb1.value
If tb2(0).Checked=True then WshShell.Run "https://www.google.com/search?q=" & Replace(tb1.value, " ", "+")
WshShell.RegWrite "HKCU\Software\StackOverflow\VBS\Searchterm", tb1.value & vbtab & WshShell.RegRead("HKCU\Software\StackOverflow\VBS\Searchterm")
If tb3.checked=true then window.close
End Sub
Sub Init
Count = 0
window.resizeTo 550, 400
' On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
HistoryArr = Split(WshShell.RegRead("HKCU\Software\StackOverflow\VBS\Searchterm"), Chr(9))
tb1.value = HistoryArr(0)
For each t in HistoryArr
Count=Count + 1
Set Hist = document.createElement("OPTION")
Hist.Text=t
Hist.Value=Count
HistoryList.Add(Hist)
Count=Count + 1
If Count > 50 then exit For
next
tb1.select
' tb1.focus
End Sub
Sub Paste
tb1.value=document.parentwindow.clipboardData.GetData("TEXT")
tb1.select
End Sub
Sub LBTransfer
x = CLng(HistoryList.Options.selectedindex)
tb1.value = HistoryList.Options(x).text
tb1.select
End Sub
Sub LBTransferK
x = CLng(HistoryList.Options.selectedindex)
tb1.value = HistoryList.Options(x).text
HistoryList.focus
End Sub
</script>
</head>
<body Onload=Init>
<p><b>Enter <u>s</u>earch term</b></p>
<p><INPUT Name=tb1 TYPE=Text size=60 AccessKey=s> <INPUT Type=Button onclick=paste Value=Paste AccessKey=p></p>
<p><b><u>H</u>istory</b></p>
<p><SELECT NAME="HistoryList" SIZE="4" Onclick=LBTransfer OnKeyPress=LBTransferK AccessKey=h>
</SELECT></p>
<p><b>Search <u>w</u>here</b></p>
<p><INPUT Name=tb2 TYPE=RADIO CHECKED AccessKey=w> Google <INPUT Name=tb2 TYPE=RADIO> Wikipedia <INPUT Name=tb2 TYPE=RADIO> Nethack <INPUT Name=tb2 TYPE=RADIO> MSDN <INPUT Name=tb2 TYPE=RADIO> Australia <INPUT Name=tb2 TYPE=RADIO> Maps </p>
<p><INPUT NAME="Search" TYPE="SUBMIT" VALUE="Search" OnClick=Search> <INPUT Name=tb3 TYPE=CHECKBOX CHECKED AccessKey=c> <u>C</u>lose on search</p>
</body>
</html>
You cannot create a radio button with VBscript. You will need to use an HTA or a different wrapper.
The error seems to be a problem of you not setting the shell object
So to use
Set objExecObject = objShell.Exec("tzutil.exe /s """ & TimeZoneFriendlyName & "")
WScript.Echo "Setting the time zone sucessfully."
You first have to have a
Set objShell = CreateObject("Wscript.Shell")
before that
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>
I have a working vbscript form with some parts based on hta code.
The form is intended to open a incident in a ticketing tool. This is also working as expected.
I intend to do some adjustments, specially adding a background wallpaper or changing color, and also adding a logo (in jpg ou png) on the top left corner of the form. I think this can be changed on the hta part of the script but I tried to apply some modifications, so far without success.
Below is the code. Any clue? Thank you very much.
Sub GetParams(sTitle, sPrompt, oParams, bAccepted, iWidth, iHeight)
Dim oWnd, sContent, aKeys, i
sContent = "<div style='font: 8pt tahoma;'>"
aKeys = oParams.Keys
For i = 0 To oParams.Count - 1
sContent = sContent & "<span style='margin: 4px;'>" & HtmlSafe(aKeys(i)) & "</span><br>"
sContent = sContent & "<input id=textbox" & i & " value='" & HtmlSafe(oParams.Item(aKeys(i))) & "' type='textbox' style='font: 8pt tahoma; width: 100%; margin: 4px;'/><br>"
Next
sContent = sContent & "<br><input onclick='window.accepted=true;' type='button' value='Criar' style='font: 8pt tahoma; width: 75px; height: 21px; float: right; margin-right: 20px;'/></div>"
Set oWnd = CreateWindow()
With oWnd
With .Document
.Title = sTitle
.Body.Style.Background = "buttonface"
.Body.InnerHtml = sContent
End With
.ResizeTo iWidth, iHeight
.MoveTo CInt((.Screen.AvailWidth - iWidth) / 2), CInt((.Screen.AvailHeight - iHeight) / 2)
End With
oWnd.ExecScript "var accepted=false;"
On Error Resume Next
Do
bAccepted = oWnd.Accepted
If bAccepted Then Exit Do
If Err.Number <> 0 Then
bAccepted = False
Exit Sub
End If
WScript.Sleep 10
Loop
For i = 0 To oParams.Count - 1
oParams(aKeys(i)) = oWnd.Document.GetElementById("textbox" & i).Value
Next
oWnd.Close
End Sub
Function HtmlSafe(sText)
HtmlSafe = Replace(Replace(Replace(Replace(sText, "&", "&"), "<", "<"), ">", ">"), vbCrLf, "<br>")
End Function
Function CreateWindow()
Dim sSignature, oShellWnd, oProc
sSignature = Left(CreateObject("Scriptlet.TypeLib").Guid, 38)
Set oProc = CreateObject("WScript.Shell").Exec("mshta ""about:<html><head><script>moveTo(-32000,-32000);document.title=' '</script><hta:application id=app border=thick minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=no innerborder=no icon=""""/><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head></html>""")
Do
If oProc.Status > 0 Then
Set CreateWindow = Nothing
Exit Function
End If
For Each oShellWnd In CreateObject("Shell.Application").Windows
On Error Resume Next
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
On Error Goto 0
Next
Loop
End Function
I suppose you want to include the image with your script, not reference one that already exists on disk. You can use CSS for that. Define the background-image property with a data URI like this:
background-image: url(data:image/png;base64,<base64-encoded image>);
Example data URI for a red 1px PNG image:
background-image: url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAIAAACQd1PeAAAACXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH3goaER0v2K3gpwAAABl0RVh0Q29tbWVudABDcmVhdGVkIHdpdGggR0lNUFeBDhcAAAAMSURBVAjXY/jPwAAAAwEBABjdjbAAAAAASUVORK5CYII=);
If you don't have a tool for converting stuff to base64 you can use an online converter.
Repetition of images is controlled via the background-repeat property. For including a logo you could make the logo the background of a <div> with repetition set to no-repeat.
If you define the style in a <style></style> block you need to specify a selector, e.g.:
<style>
body {
background-image: url(data:image/png;base64,iVBORw0K...);
}
</style>
Otherwise you'll have to put it in the style attribute of a tag, e.g.:
<body style="background-image: url(data:image/png;base64,iVBORw0K...);">