I dynamically create two columns in a table with column 1 having a bunch of buttons (to install apps on a remote PC) and column 2 being a multiple select box showing apps installed. I decided to add a span below the multiple select box showing the status of apps being installed or uninstalled via UninstallStatusArea.InnerText and weirdly the buttons in column 1 move down a line feed when UninstallStatusArea.InnerText contains characters, and then they move back up to their original location when UninstallStatusArea.InnerText = "".
Why is that, or asked another way, how can I make the two columns completely independent of one another? It's actually not a huge deal, rather just an academic exercise that bothers the heck out of me.
<html>
<head>
<title>Get System Information</title>
<HTA:APPLICATION
APPLICATIONNAME="Get System Information"
ID="GetPCInfo"
border="thin"
MAXIMIZEBUTTON="no"
SCROLL="NO"/>
</head>
<script language="VBScript">
Public ApplicationList()
Sub Window_OnLoad
document.body.bgColor = "Silver"
document.body.style.fontFamily = "Calibri"
document.body.style.fontSize = "12 pt"
document.body.style.color = "black"
window.offscreenBuffering = True 'helps window refresh sometimes
window.resizeTo 1100,720 'width,height
window.moveTo (screen.width - document.body.clientwidth)/2, (screen.availheight - document.body.clientheight)/2
Tab1.InnerText = "Applications"
strComputer = "."
Panel1.InnerHTML = "<hr color=""black""><TABLE align=""center"" border=""0"" cellspacing=""1"" width=""80%"">" &_
"<TR id=""Applications""><TD align=""left"">" &_
"<button name=""InstallFF"" id=""InstallFF"" Title=""Clicking on this button will install FireFox."" value=""Install FF"" style=""background-color:orange; color:black; border: 1pt ridge black"">Install FireFox</button>" &_
"<BR><BR><button name=""InstallChrome"" id=""InstallChrome"" Title=""Clicking on this button will install Chrome."" value=""Install Chrome"" style=""background-color:orange; color:black; border: 1pt ridge black"">Install Chrome</button>" &_
"<BR><BR><BR><BR><button name=""UninstallApps"" id=""UninstallApps"" Title=""Clicking on this button will uninstall applications."" value=""Uninstall Apps""" &_
" style=""background-color:red; color:black; border: 1pt ridge black"" onclick=""OnClickUninstallApps"">Uninstall Applications </button><BR><span id = ""DataArea_Applications""></span>" &_
"<input id=""DontPromptBox"" type=""checkbox"">Don't prompt, just do it!</TD>" &_
"<TD align=""left"">" &_
"<div style=""overflow:auto; width:550x;"">" &_
"<select multiple size=""25"" name=""applistbox""></select></div><span id=""UninstallStatusArea"" font style=color:red;font-weight=bold;></span></TD></TR></Table>"
UninstallStatusArea.InnerText = ""
DontPromptBox.checked = True
Call Get_Applications(strComputer)
End Sub
'===================================
'== SUB GET APPLICATION LIST =====
'===================================
Sub Get_Applications(strComputerName)
Dim UnInstallList(), InstallDateList(), InstallRegList()
Dim strTemp, strTemp2, strTemp3, strValue1, strValue2, strValue3, strValue4, temp, temp2, temp3, temp4
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
strEntry1 = "DisplayName"
strEntry2 = "DisplayVersion"
strEntry3 = "UninstallString"
strEntry4 = "InstallDate"
Set objReg = GetObject("winmgmts://" & strComputerName & "/root/default:StdRegProv")
objReg.EnumKey HKLM, strKey, arrSubkeys
i = 0
For Each strSubkey In arrSubkeys
strTemp = "" : strTemp2 = "" : strTemp3 = ""
strValue1 = "" : strValue2 = "" : strValue3 = "" : strValue4 = ""
intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1, strValue1)
If intRet1 <> 0 Then objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1, strValue1
If strValue1 <> "" Then strTemp = strValue1
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2
If strValue2 <> "" Then strTemp = strTemp & " Version: " & strValue2
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry3, strValue3
If strValue3 <> "" Then strTemp2 = strValue3
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry4, strValue4
If strValue4 <> "" Then strTemp3 = strValue4
ReDim Preserve ApplicationList(i)
ReDim Preserve UnInstallList(i)
ReDim Preserve InstallDateList(i)
ReDim Preserve InstallRegList(i)
If Len(strTemp) > 8 Then
If Len(strTemp2) > 8 Then
ApplicationList(i) = strTemp
UnInstallList(i) = strTemp2
InstallDateList(i) = strTemp3
InstallRegList(i) = strKey & strSubkey
i = i + 1
End If
End if
Next
'now look at x64 keys
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputerName & "\root\cimv2")
Set colOS = objWMIService.ExecQuery ("Select * From Win32_OperatingSystem")
For Each objItem In colOS
strArch = objItem.OSArchitecture
Next
If InStr(strArch,"64") Then
strKey = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall\"
objReg.EnumKey HKLM, strKey, arrSubkeys
For Each strSubkey In arrSubkeys
strTemp = ""
strTemp2 = ""
strTemp3 = ""
strValue1 = ""
strValue2 = ""
strValue3 = ""
strValue4 = ""
intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1, strValue1)
If intRet1 <> 0 Then objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1, strValue1
If strValue1 <> "" Then strTemp = strValue1
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2
If strValue2 <> "" Then strTemp = strTemp & " Version: " & strValue2
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry3, strValue3
If strValue3 <> "" Then strTemp2 = strValue3
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry4, strValue4
If strValue3 <> "" Then strTemp3 = strValue4
ReDim Preserve ApplicationList(i)
ReDim Preserve UnInstallList(i)
ReDim Preserve InstallDateList(i)
ReDim Preserve InstallRegList(i)
If Len(strTemp) > 8 Then
If Len(strTemp2) > 8 Then
ApplicationList(i) = strTemp
UnInstallList(i) = strTemp2
InstallDateList(i) = strTemp3
InstallRegList(i) = strKey & strSubkey
i = i + 1
End If
End if
Next
End If
'alphabatize the array for easier readability
For a = UBound(ApplicationList) - 1 To 0 Step -1
For j = 0 to a
If LCase(ApplicationList(j)) > LCase(ApplicationList(j+1)) then
temp = ApplicationList(j+1)
temp2 = UnInstallList(j+1)
temp3 = InstallDateList(j+1)
temp4 = InstallRegList(j+1)
ApplicationList(j+1) = ApplicationList(j)
UnInstallList(j+1) = UnInstallList(j)
InstallDateList(j+1) = InstallDateList(j)
InstallRegList(j+1) = InstallRegList(j)
ApplicationList(j) = temp
UnInstallList(j) = temp2
InstallDateList(j) = temp3
InstallRegList(j) = temp4
End If
Next
Next
'create the listbox from the array
For j = 0 To UBound(ApplicationList)
Set objOption = Document.createElement("OPTION")
objOption.Text = ApplicationList(j)
If Len(InstallDateList(j)) > 0 then objOption.Text = objOption.Text & ", Install Date: " & InstallDateList(j)
objOption.Value = UnInstallList(j)
objOption.title = "Uninstall details found in Registry key:" & vbCrLf & InstallRegList(j)
objOption.style.backgroundcolor = "#D4E5B3"
applistbox.Add(objOption)
Next
End Sub
'==================================
'== SUB UNINSTALL APPLICATIONS ==
'==================================
Sub OnClickUninstallApps()
Dim i, j, iFind, UninstallString, UninstallRegString, strTemp23, strResults, iSelect, strComputerName
Dim objShell : set objShell = CreateObject("WScript.Shell")
strComputerName = "."
ShowCommand = 0
PSExec = "c:\pstools\psexec.exe -s -h \\"
strResults = ""
iSelect = 0
For i = 0 To applistbox.length - 1
If applistbox(i).selected Then
iSelect = 1
UninstallStatusArea.InnerText = "Currently uninstalling " & applistbox(i).Text
Call SleepWait(2) 'rather than uninstall, display the text for troubleshooting purposes
UninstallStatusArea.InnerText = " "
SleepWait(1)
strResults = strResults & applistbox(i).Text & vbCrLf & vbCrLf
End If
Next
If iSelect = 1 Then
Call ClearAppListbox()
Call Get_Applications(strComputerName)
set objShell = CreateObject("WScript.Shell")
objShell.Popup strResults,0,strComputerName & " - Uninstall Results"
Else
MsgBox "No applications selected to uninstall.",vbOKOnly,"I did nothing"
End If
End Sub
'===============================
'== SUB CLEAR APP LISTBOX ====
'===============================
Sub ClearAppListbox()
For Each objOption in applistbox.Options
objOption.RemoveNode
Next
End Sub
'========================================
'= SleepWait - Momentary pause ==========
'========================================
Sub SleepWait(timeinseconds) 'Allows application to wait, if needed.
If timeinseconds = 0 Then timeinseconds = 0.2
With CreateObject("WScript.Shell")
.run "timeout " & timeinseconds, 0, True
End With
End Sub
</script>
<!--
===================================
== JAVASCRIPT =====================
===================================
-->
<script type="text/javascript">
var panels = new Array("","panel1","panel2");
function panel(tab) {
for (i=1; i<panels.length; i++) {
if (i == tab) {
document.getElementById("tab"+i).className = "tabs tabs1";
document.getElementById("panel"+i).style.display = "block";
} else {
document.getElementById("tab"+i).className = "tabs tabs0";
document.getElementById("panel"+i).style.display = "none";
}
}
}
</script>
<style type="text/css">
body,td,th { font-family:Calibri }
.head { font-size:110%; font-weight:bold }
.panel {
background-color: skyblue;
border: solid 1px black;
height: 480px;
padding: 5px;
position: relative;
width: 1000px;
z-index: 0;
}
.tabs {
border-collapse: collapse;
color: black;
cursor: pointer;
cursor: hand;
font-family: calibri;
font-size: 9pt;
font-weight: bold;
margin-top: 4px;
padding: 2px 4px 0px 4px;
position: relative;
text-align: center;
text-decoration: none;
z-index: 1;
}
.tabs0 {
background-color: wheat;
border: solid 1px black;
}
.tabs1 {
background-color: skyblue;
border-color: black black silver black;
border-style: solid solid solid solid;
border-width: 1px 1px 1px 1px;
}
hr {
border: 1;
width: 99%;
background-color: #0000FF;
height: 3px;
}
button {
color: white;
background-color: #4F7BA6;
border: 1px solid darkblue;
}
</style>
</head>
<body>
<table align="center" border="0" cellpadding="0" cellspacing="0" width="1000">
<tr valign="top">
<td colspan="2">
<span class="tabs tabs1" id="tab1" onclick="panel(1)">Tab1</span>
<span class="tabs tabs0" id="tab2" onclick="panel(2)">Tab2</span>
<div class="panel" id="panel1" style="display:block">
</div>
<div class="panel" id="panel2" style="display:none">
</div>
</td>
</tr>
</table>
</body>
</html>
To see what is happening, highlight a few apps and click on the red button (it actually does nothing now but bounce things up & down).
You put a nested table into your panel, with a 2-column layout like this:
+------------------------------------------------------------+
| +-------------------+ +----------------------------------+ |
| | | | +------------------------------+ | |
| | | | | Listbox | | |
| | | | | | | |
| | Buttons | | | | | |
| | | | | | | |
| | | | | | | |
| | | | +------------------------------+ | |
| | | | =============[span]============= | |
| +-------------------+ +----------------------------------+ |
+------------------------------------------------------------+
The left cell contains your buttons, the right cell your listbox. Below the listbox you put an empty <span> (with the ID UninstallStatusArea). Whenever you put text into that <span> element it changes the height of the right cell and thus of the entire row, including the left cell. Changing the height of that cell is what moves the buttons, because they're vertically centered, so they'll shift whenever the cell's vertical size changes.
There are several ways how you could deal with this issue, for instance:
Change the vertical alignment of the cells to top so they stick to the top rather than "float" in the middle:
<style type="text/css">
body,td,th { font-family:Calibri; }
td { vertical-align: top; }
...
Set a height for the <span> element:
<span id="UninstallStatusArea" style="color:red;...;height:40px;">
Move the span to a second table row:
...
</tr>
<tr>
<td> </td>
<td><span id="UninstallStatusArea" ...></td>
</tr>
</table>
Remove the table(s) and switch to a completely <div> and CSS based layout.
Related
This question already has answers here:
Inputbox() function in vbs
(2 answers)
Closed 2 months ago.
I need to change icon on left corner to atts.ico.
I tried
message=InputBox("ATTS","atts.ico","Enter text to speech.")
But it didn't work...
Refer to this link Multiline inputbox via HTA written by omegastripes
Just change the path to your icon in this line on this vbscript below : %windir%\system32\notepad.exe and give a test for it
dim completed,INPUT
INPUT=inputboxml("Enter text:", "Multiline inputbox via HTA", "default" & vbcrlf & vbtab & "multiline" & vbcrlf & "text")
CreateObject("SAPI.spVoice").speak INPUT
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: 580px;'>" & 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 700, 700
.moveto 300, 50
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
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.
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...);">