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
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
How to read something from Command prompt using Vbscript ?
For example :
If I run date /T command it will return current system date.
So how to read the output date ?
Thanks !
Something like that :
Msgbox RunDos("Date /T")
'******************************************************************************************
Function RunDos(strCommand)
Dim wsh, fs, ts
Dim strTempFile, strData
Const ForReading = 1
Const TemporaryFolder = 2
Const WshHide = 0
Set wsh = CreateObject("Wscript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
strTempFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder).Path, fs.GetTempName)
wsh.Run "cmd.exe /c " & strCommand & " > """ & strTempFile & """", WshHide, True
Set ts = fs.OpenTextFile(strTempFile, ForReading, True)
strData = ts.ReadAll
RunDos = strData
ts.Close
End Function
'******************************************************************************************
EDIT : Adding another code with inputbox
Option Explicit
Dim Mycmd
Mycmd = InputBox("Type a command line to be executed ! "& vbcr &"For example Ping www.google.com",_
"Type a command line to be executed !","Ping www.google.com")
If Mycmd = "" Then Wscript.Quit
wscript.echo Run_Cmd(Mycmd)
'**********************************************************************************************
Function Run_Cmd(strCommand)
Const ForReading = 1
Const TemporaryFolder = 2
Const WshHide = 0
Dim wsh, fs, ts
Dim strTempFile,strFile, strData
Set wsh = CreateObject("Wscript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
strTempFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder).Path, fs.GetTempName)
strFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder).Path, "result.txt")
wsh.Run "cmd.exe /c " & strCommand & " > " & DblQuote(strTempFile) & "2>&1", WshHide, True
wsh.Run "cmd.exe /u /c Type " & DblQuote(strTempFile) & " > " & DblQuote(strFile) & "", WshHide, True
Set ts = fs.OpenTextFile(strFile, ForReading,true,-1)
strData = ts.ReadAll
Run_Cmd = strData
ts.Close
fs.DeleteFile strTempFile
fs.DeleteFile strFile
End Function
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
And this another one showing you how to execute a command line with a HTA file : CommandLine.hta
<html>
<title>Execution of command line with HTA by Hackoo</title>
<head>
<HTA:APPLICATION
APPLICATIONNAME="Execution of command line with HTA by Hackoo"
SCROLL="no"
SINGLEINSTANCE="yes"
WINDOWSTATE="maximize"
ICON="Winver.exe"
/>
</head>
<META HTTP-EQUIV="MSThemeCompatible" CONTENT="YES">
<script language="VBScript">
Option Explicit
Dim Title : Title = "Execution of command line with HTA by Hackoo"
'**********************************************************************************************
Sub Window_OnLoad
Call Run_Cmd("help")
End Sub
'**********************************************************************************************
Sub Run_Cmd(strCommand)
On Error Resume Next
If input.value = "" Then
MsgBox "ATTENTION ! The text box is empty !"& vbcr &_
"You forgot to type a command on the text box !",vbExclamation,Title
Exit Sub
End if
Output.value = ""
btnClick.disabled = True
document.body.style.cursor = "wait"
btnClick.style.cursor = "wait"
Const ForReading = 1
Const TristateTrue = -1
Const TemporaryFolder = 2
Const WshHide = 0
Dim wsh, fs, ts
Dim strTempFile,strFile, strData
Set wsh = CreateObject("Wscript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
strTempFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder).Path, fs.GetTempName)
strFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder).Path, "result.txt")
wsh.Run "cmd.exe /c " & strCommand & " > " & DblQuote(strTempFile) & "2>&1", WshHide, True
wsh.Run "cmd.exe /u /c Type " & DblQuote(strTempFile) & " > " & DblQuote(strFile) & "", WshHide, True
Set ts = fs.OpenTextFile(strFile,ForReading,True,TristateTrue)
strData = ts.ReadAll
Output.Value = "Microsoft Windows [version 7.1 7631]" & vbcrlf &_
"Copyright (c) 2009 Microsoft Corporation. All rights reserved." & vbcrlf & vbcrlf &_
"C:\>"& strCommand & vbcrlf & strData
ts.Close
fs.DeleteFile strTempFile
fs.DeleteFile strFile
document.body.style.cursor = "default"
btnClick.style.cursor = "default"
btnClick.disabled = False
End Sub
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
Sub OnClickButtonCopy()
document.parentwindow.clipboardData.SetData "text", Output.Value
MsgBox "The ouput result is copied to the clipboard !",vbInformation,Title
End Sub
'**********************************************************************************************
</script>
</head>
<body bgcolor="123456" text=darkorange>
<hr>
<center><FONT SIZE="3"><B><I>Some examples of commands</I></B></FONT><BR>
<select style="background-color:lightblue" name="DropDown">
<option value="CD %Programfiles%\Mozilla Firefox\ | Start Firefox.exe">CD %Programfiles%\Mozilla Firefox\ | Start Firefox.exe</option>
<option value="Tracert www.google.fr">Tracert www.google.fr</option>
<option value="Start iexplore">Start iexplore</option>
<option value="Start Notepad">Start Notepad</option>
<option value="Start Winword">Start Winword</option>
<option value="Explorer.exe /n,/e,/root,C:\Program Files">Explorer.exe /n,/e,/root,C:\Program Files</option>
<option value="Ipconfig">IpConfig</option>
<option value="Dir">Dir</option>
<option value="Ping www.yahoo.fr">Ping www.yahoo.fr</option>
<option value="Ping www.google.fr">Ping www.google.fr</option>
</select>
<input type="button" onClick="Run_Cmd(DropDown.value)" value="Run this command">
<center><hr><B><I>Type your input command here</I></B><br>
<input type="text" Name="input" size="10"style="width:100%" value="Ping www.google.com" style="background-color:lightblue">
<input type="submit" name="btnClick" value="Run the input command line" onclick="Run_Cmd(input.value)">
<br><hr><B><I> The output result (readonly)</I></B><hr>
<textarea readonly id="Output" style="width:100%" rows="28" style="background-color:black; color:white">Microsoft Windows [version 7.1 7631]
Copyright (c) 2009 Microsoft Corporation. All rights reserved.
C:\></textarea><input type="button" name="ButtonCopy" value="Copy the ouput result to the Clipboard" onclick="OnClickButtonCopy">
<hr></center>
</body>
</html>
Screenshot of CommandLine.hta
You can use the WshScriptExec object obtained from %comspec% /c date /T:
>> WScript.Echo CreateObject("WScript.Shell").Exec("%comspec% /c date /T").Stdout.ReadAll()
>>
10.02.2016
but a simple
>> WScript.Echo Date()
>>
10.02.2016
is less risky.
I have a VBS script that maps a drive. Depending on the user either a generic folder (requiring no credentials) or a personal folder (requiring a username and password) is mapped. I'm currently using standard WSH inputs for this, which obviously isn't too secure as the password is un-masked
I've looked in to solutions using ScriptPW.dll, but this is no longer native to Windows (I'm using Windows 7) and doesn't work when copied from XP and registered.
One solution I'm looking at now is to use an HTA to prompt for the username/password. I've got to the point of running the file when it would be required, but I'm not sure how to (or even if I can) return the input values from the form to the parent script.
Is this possible?
Note - As the form is not required in all circumstances, I cannot place the whole script within the HTA.
Here is how I'm calling the HTA -
Dim Shell
Set Shell = Wscript.CreateObject("Wscript.Shell")
Shell.Run("test.hta"), 1, True
Set Shell = Nothing
And here is the HTA -
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252" />
<title>Login Application</title>
<hta :application
applicationname="LoginBox"
border="dialog"
borderstyle="normal"
caption="My HTML Application"
contextmenu="no"
maximizebutton="no"
minimizebutton="yes"
navigable="no"
selection="no"
showintaskbar="yes"
singleinstance="yes"
sysmenu="yes"
version="1.0"
windowstate="normal" />
</head>
<body>
<form id="LoginForm">
Enter Username: <input type="textbox" id="UserName"/><br />
Enter Password: <input type="password" id="Password"/><br />
<input type="submit" value="Open my scans"/>
</form>
</body>
</html>
I think this function PasswordBox can help you, just give a try ;)
' Just an example of how to use the function
'
wsh.echo "You entered: ", _
Join(PasswordBox("Enter UID and password", _
"Testing"), ", ")
' A function to present a Password dialog in a VBS (WSF)
' script
' Requires WScript version 5.1+
' Tom Lavedas <tlavedas#hotmail.com>
' with help from and thanks to Joe Ernest and
' Michael Harris
'
' modified 1/2008 to handle IE7
'
Function PasswordBox(sPrompt,sDefault)
set oIE = CreateObject("InternetExplorer.Application")
With oIE
' Configure the IE window
.RegisterAsDropTarget = False
.statusbar = false : .toolbar = false
.menubar = false : .addressbar = false
.Resizable = False
.Navigate "about:blank"
Do Until .ReadyState = 4 : WScript.Sleep 50 : Loop
' Test for IE 7 - cannot remove 'chrome' in that version
sVersion = .document.parentWindow.navigator.appVersion
if instr(sVersion, "MSIE 7.0") = 0 Then .FullScreen = True
.width = 400 : .height = 270
' Create the password box document
With .document
oIE.left = .parentWindow.screen.width \ 2 - 200
oIE.top = .parentWindow.screen.height\ 2 - 100
.open
.write "<html><head><" & "script>bboxwait=true;</" _
& "script><title>Password _</title></head>"_
& "<body bgColor=silver scroll=no " _
& "language=vbs style='border-" _
& "style:outset;border-Width:3px'" _
& " onHelp='window.event.returnvalue=false" _
& ":window.event.cancelbubble=true'" _
& " oncontextmenu=" _
& "'window.event.returnvalue=false" _
& ":window.event.cancelbubble=true'" _
& " onkeydown='if ((window.event.keycode>111)"_
& " and (window.event.keycode<117)) or" _
& " window.event.ctrlkey then" _
& " window.event.keycode=0" _
& ":window.event.cancelbubble=true" _
& ":window.event.returnvalue=false'" _
& " onkeypress='if window.event.keycode=13" _
& " then bboxwait=false'><center>" _
& "<div style='padding:10px;background-color:lightblue'>" _
& "<b> " & sPrompt & "<b> </div><p>" _
& "<table bgcolor=cornsilk cellspacing=10><tr><td>" _
& " <b>User:</b></td><td>" _
& "<input type=text size=10 id=user value='" _
& sDefault & "'>" _
& "</td><tr><td> <b>Password:</b></td><td>" _
& "<input type=password size=12 id=pass>" _
& "</td></tr></table><br>" _
& "<button onclick='bboxwait=false;'>" _
& " Okay " _
& "</button> <button onclick=" _
& "'document.all.user.value=""CANCELLED"";" _
& "document.all.pass.value="""";" _
& "bboxwait=false;'>Cancel" _
& "</button></center></body></html>"
.close
Do Until .ReadyState = "complete" : WScript.Sleep 100 : Loop
.all.user.focus
.all.user.select ' Optional
oIE.Visible = True
CreateObject("Wscript.Shell")_
.Appactivate "Password _"
PasswordBox = Array("CANCELLED")
On Error Resume Next
Do While .parentWindow.bBoxWait
if Err Then Exit Function
WScript.Sleep 100
Loop
oIE.Visible = False
PasswordBox = Array(.all.user.value, _
.all.pass.value)
End With ' document
End With ' IE
End Function
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>