I needed a small HTA to give a couple list boxes and submit button that would kick off some SQL bits. All was well when the HTML portion was static but when I try to make it dynamic so that current month/year can be default in the drop downs the code quits working and says that my ButtonClick is undefined.
Here is a simplified version of the code. I've tried just using btn01_OnClick, ButtonClick() and a few other fruitless variations. Thoughts?
<HEAD>
<TITLE>Drop Down Menu</TITLE>
<HTA:APPLICATION ID="oMyApp"
APPLICATIONNAME="Drop Down"
BORDER="Dialog"
CAPTION="Yes"
SCROLL="NO"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SYSMENU="Yes"
WINDOWSTATE="maximize">
</HEAD>
<SCRIPT LANGUAGE="VBScript">
Sub ButtonClick
Document.write ("Success")
End Sub
Sub Window_OnLoad
strHTML = strHTML & "<BODY><SPAN>"
strHTML = strHTML & "<H2>Select Month</H2>"
strHTML = strHTML & "<P>Select Month: "
strHTML = strHTML & "<SELECT NAME=""Month"">"
strHTML = strHTML & "<OPTION selected>" & MonthName(Month(Date),False) & "</OPTION>"
strHTML = strHTML & "<OPTION>January</OPTION>"
strHTML = strHTML & "</SELECT><P>"
strHTML = strHTML & "<P>Select Year: "
strHTML = strHTML & "<SELECT NAME=""Year"">"
strHTML = strHTML & "<OPTION selected>" & Year(Date) & "</OPTION>"
strHTML = strHTML & "<OPTION>2014</OPTION>"
strHTML = strHTML & "</SELECT><P>"
strHTML = strHTML & "<BR><BR>"
strHTML = strHTML & "<Input Type = " & Chr(34) & "Button" & Chr(34) & " Name = " & Chr(34) & "btn01" & Chr(34) & " onClick = " & Chr(34) & "ButtonClick" & Chr(34) & " VALUE = " & Chr(34) & "SUBMIT" & Chr(34) & ">"
strHTML = strHTML & "<BR><BR></SPAN>"
strHTML = strHTML & "</BODY>"
Document.write(strHTML)
Window.Month.Focus
End Sub
</SCRIPT>
Your script section should be part of the <head> section, and I'd use
Document.body.innerHtml = strHTML
instead of
Document.write strHTML
Example:
<html>
<head>
<title>Drop Down Menu</title>
<HTA:APPLICATION ID="oMyApp"
...
WINDOWSTATE="maximize">
<script language="VBScript">
Sub ButtonClick
Document.write "Success"
End Sub
Sub Window_OnLoad
strHTML = "<SPAN>"
...
strHTML = strHTML & "<BR><BR></SPAN>"
Document.body.innerHtml = strHTML
Window.Month.Focus
End Sub
</script>
</head>
<body>
</body>
</html>
Related
I can get each one to work by themselves but I can not get them to work together, the logon script uses the strArg = to call on the HTA file, the HTA file generates a password window. When the logon script runs the HTA file errors out on lines 31 and 106.
I know the issue lies within the strArg, I can not figure it out. It should be notifying endusers at the 13 days before expiring mark. Any help would be great. Currently, as the script is now, I get an error with the HTA file part:
Line: 31 and 106
Error: Type Mismatch 'strARG'
code: 0
I did open the question in the link below but those suggestions did not solve the problem.
vbscript statement mismatch sring failing
Dim oDomain
Dim oUser
Dim maxPwdAge
Dim numDays
Dim warningDays
warningDays = 13
Set LoginInfo = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & LoginInfo.UserName & "")
strDomainDN = UCase(LoginInfo.DomainDNSName)
strUserDN = LoginInfo.UserName
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
intUserAccountControl = objUser.Get("userAccountControl")
If intUserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then
'WScript.Echo "The password does not expire."
Else
Set oDomain = GetObject("LDAP://" & strDomainDN)
Set maxPwdAge = oDomain.Get("maxPwdAge")
' Calculate the number of days that are held in this value.
numDays = CCur((maxPwdAge.HighPart * 2 ^ 32) + _
maxPwdAge.LowPart) / CCur(-864000000000)
'WScript.Echo "Maximum Password Age: " & numDays
Set oUser = GetObject("LDAP://" & strUserDN)
whenPasswordExpires = DateAdd("d", numDays, oUser.PasswordLastChanged)
fromDate = Date
daysLeft = DateDiff("d", fromDate, whenPasswordExpires)
'WScript.Echo "Password Last Changed: " & oUser.PasswordLastChanged
If (daysLeft < warningDays) And (daysLeft > -1) Then
strCMD = "\\domain\netlogon\PwExpChk\PWReminder.hta" & " -" & intDaysRemaining
Set wshShell = CreateObject("WScript.Shell")
RC = WshShell.Run(strCMD , 0, False)
End If
End If
Set oUser = Nothing
Set maxPwdAge = Nothing
Set oDomain = Nothing
Set wshShell = Nothing
The HTA file:
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>Password Reminder</title>
<hta:application
border="thin
borderstyle="normal"
caption="Password Reminder"
contextmenu="yes"
maximizebutton="Yes"
minimizebutton="no"
navigable="yes"
scroll="no"
selection="yes"
showintaskbar="yes"
singleinstance="yes"
sysmenu="Yes"
WINDOWSTATE="normal"
id="objPasswordHTA">
<script language="vbscript">
Sub Window_onLoad
strArg = 13
arrCommands = Split(objPasswordHTA.commandLine, "-")
If UBound(arrCommands) > 0 Then
strArg = arrCommands(UBound(arrCommands))
End If
'setup the window size depending on how many days remain
strArg = strArg * 1
If strArg <= 5 Then
self.MoveTo 200,50
window.ResizeTo 1000,850
Set wshShell = CreateObject("WScript.Shell")
wshShell.AppActivate "Password Reminder"
wshShell.SendKeys "% x" ' ALT+SPACE+X = windows maximize, must be enabled on hta
' ALT+SPACE+N = windows minimize, must be enabled on hta
' ALT+SPACE+R = windows restore
ElseIf strArg <= 10 Then
self.MoveTo 200,50
window.ResizeTo 900,750
Else
self.MoveTo 200,50
window.ResizeTo 750, 575
End If
End Sub
</script>
</head>
<body>
<table cellspacing="0" cellpadding="0" width="100%" bgcolor=Silver>
<tbody>
<tr>
<td valign="top" width="80%">
<p style="PADDING-TOP: 8px; PADDING-LEFT: 8px; margin-top: 0px">
<font face="Verdana" color="White" style="font-size: 11pt"><strong>Company name</strong></font><br />
<font face="Verdana" color="Black" size="5"><strong>Password Reset Reminder</strong></font>
<p>
</td>
<td valign="bottom" width="50%">
<img src='\\domain\netlogon\PwExpChk\logo.jpg' width='451' height='170' style="vertical-align:bottom;">
</td>
</tr>
</tbody>
</table>
<span id=DataArea></span>
<script language="vbscript">
Set wshNetwork = reateObject("WScript.Network")
Set wshShell = CreateObject("Wscript.Shell")
'TableMsgs:
strDaysLeftMsg1 = "We have detected that your password will expire in"
strDaysLeftMsg2 = "day(s) or less."
strPWCriteriaMsg = "<BR>Password criteria:" & _
"<BR> - 8 characters or longer" & _
"<BR> - At least one alpha, one numeric, and one special character" & _
"<BR> - Cannot be an old password" & _
"<BR> - Passwords ARE CaSe SeNsItIvE!!!" & _
"<BR>"
strArg = 13
arrCommands = Split(objPasswordHTA.commandLine, "-")
If UBound(arrCommands) > 0 Then
strArg = arrCommands(UBound(arrCommands))
strArg = strArg * 1
End If
intDaysLeftonPW = strArg
'Generate the HTML for the table
strTableHTML = "<TABLE align=center width=75%>"
If intDaysLeftonPW <= 5 Then
strTableHTML = strTableHTML & "<font size=5>"
strTableHTML = strTableHTML & "<TR bgcolor=Red><TD> </TD></TR>"
strTableHTML = strTableHTML & "<TR><TD><font size=5>" & strDaysLeftMsg1 & "<font color=Red><b> " & intDaysLeftonPW & _
"</b></font> " & strDaysLeftMsg2 & "</font>" & _
"<BR>" & _
"<BR>Please reset your password now to avoid getting locked out or expiring. " & _
"The only way to unlock an expired password is to contact Help Desk. " & _
"A typical expired password request takes 15-20 minutes.</TD></TR>"
strTableHTML = strTableHTML & "<TR bgcolor=Red><TD> </TD></TR>"
strTableHTML = strTableHTML & "<TR><TD>" & strPWCriteriaMsg & "</TD></TR>"
strTableHTML = strTableHTML & _
"<TR><TD><BR><font color=red>To reset password:</font>" & _
"<BR>1. Press CTRL+ALT+DELETE" & _
"<BR>2. Select " & Chr(34) & "Change a Password..." & Chr(34) & _
"<BR>3. Complete the password reset wizard." & _
"<BR>" & _
"<BR>Caution: There are no grace logons. Expired passwords will not be allowed onto " & _
"the network.</TD></TR>"
strTableHTML = strTableHTML & "</font>"
ElseIf intDaysLeftonPW <= 10 Then
strTableHTML = strTableHTML & "<TR bgcolor=yellow><TD> </TD></TR>"
sTRTableHTML = strTableHTML & _
"<TR><TD>" & strDaysLeftMsg1 & "<font color=Red><b> " & intDaysLeftonPW & _
"</b></font> " & strDaysLeftMsg2 & "</TD></TR>"
strTableHTML = strTableHTML & "<TR bgcolor=Yellow><TD> </TD></TR>"
strTableHTML = strTableHTML & "<TR><TD>" & strPWCriteriaMsg & "</TD></TR>"
strTableHTML = strTableHTML & _
"<TR><TD><BR>To reset password:" & _
"<BR>1. Press CTRL+ALT+DELETE" & _
"<BR>2. Select " & Chr(34) & "Change a Password..." & Chr(34) & _
"<BR>3. Complete the password reset wizard." & _
"<BR>" & _
"<BR>Tip: Try to avoid resetting passwords on Friday and reset early in " & _
"the week. This will give you more opportunities to sign in and get used to the new password " & _
"so you do not forget over the weekend.</TD></TR>"
Else
strTableHTML = strTableHTML & "<TR bgcolor=Green><TD> </TD></TR>"
strTableHTML = strTableHTML & _
"<TR><TD>" & strDaysLeftMsg1 & "<font color=Red><b> " & intDaysLeftonPW & _
"</b></font> " & strDaysLeftMsg2 & "</TD></TR>"
strTableHTML = strTableHTML & "<TR bgcolor=Green><TD> </TD></TR>"
strTableHTML = strTableHTML & "<TR><TD>" & strPWCriteriaMsg & "</TD></TR>"
strTableHTML = strTableHTML & _
"<TR><TD><BR>Please press CTRL+ALT+DELETE and select Change a Password..." & _
"</TD></TR>"
End If
'Add the dynamic HTML to the table/HTA
strTableHTML = strTableHTML & "</TABLE>"
DataArea.InnerHTML = strTableHTML
</script>
</body>
</html>
There is your culprit:
strCMD = "\\domain\netlogon\PwExpChk\PWReminder.hta" & " -" & intDaysRemaining
' ~~~~~~~~~~~~~~~~
You never define intDaysRemaining anywhere in your code, so the variable is empty, meaning your commandline looks like this:
\\domain\netlogon\PwExpChk\PWReminder.hta -
Splitting this commandline at - gives you an array with an empty string in the last field, which in turn raises the error you observed when you try to multiplicate an empty string with 1.
Demonstration:
>>> cmdline = "\\domain\netlogon\PwExpChk\PWReminder.hta -"
>>> a = Split(cmdline, "-")
>>> v = a(UBound(a))
>>> WScript.Echo "_" & v & "_"
__
>>> i = v * 1
Type mismatch (0xD)
You would have spotted this right away had you added Option Explicit to your VBScript, or at least bothered to echo the commandline in your HTA when debugging (MsgBox objPasswordHTA.commandLine).
If a user enters the an incorrect hostname. i want the script to display a msgbox "PC wmi broken or is offline" it diplays an error but as this is being sent out to others, i'd just like a basic error msg box
Sub WindowsLoad1
strHTML = strHTML & "<br>" & "<font face='Arial' size='2' color='white''>"
strComputer = MachineName.Value
strHTML = strHTML & "<b>Sys Info</b><br> <br>"
strHTML = strHTML & "</font><font face='Arial' size='2'>"
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colComputer = objWMIService.ExecQuery ("Select * from Win32_ComputerSystem")
For Each objComputer in colComputer
strHTML = strHTML & "<b>Hostname</b>: " & objComputer.Name & "<br>"
strHTML = strHTML & "<b>Current User</b>: " & objComputer.UserName & "<br>"
strHTML = strHTML & "<b>Manufacturer</b>: " & objComputer.Manufacturer & "<br>"
strHTML = strHTML & "<b>Model</b>: " & objComputer.Model & "<br>"
Next
strHTML = strHTML& "<br>" & "<font face='Arial' size='2' color='white''>"
strComputer = MachineName.Value
strHTML = strHTML& "<b>Serial Number</b><br> <br>"
strHTML = strHTML&"</font><font face='Arial' size='2'>"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_BIOS")
For Each objItem in colItems
strHTML4 = strHTML4 & " " & objItem.SerialNumber & "<br><br>"
next
strHTML3 = "<font face='Arial' size='2' color='white''>"
strComputer = MachineName.Value
strHTML3 = strHTML3 & "<b>Windows Operating System Summary</b><br> <br>"
strHTML3 = strHTML3 &"</font><font face='Arial' size='2'>"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objItem in colItems
strHTML3 = strHTML3 & "<b>Caption</b>: " & objItem.Caption & "<br>"
strHTML3 = strHTML3 & "<b>Version</b>: " & objItem.Version & "<br>"
strHTML3 = strHTML3 & "<b>Service Pack</b>: " & objItem.ServicePackMajorVersion & "<br>"
Next
strHTML3 = strHTML3 & "<br>" & "<br>" & "<font face='Arial' size='2' color='white''>"
'strHTML3 = strHTML3 & "<b>Last Reboot</b><br> <br>"
strHTML3 = strHTML3 & "</font><font face='Arial' size='2'>"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objItem in colItems
dtmInstallDate = objItem.LastBootUpTime
'WMIDateStringToDate = FormatDateTime(dtmInstallDate,1) & " " & FormatDateTime(dtmInstallDate,4)
'WMIDateStringToDate = CDate(Left(dtmInstallDate, 4) & "/" & Mid(dtmInstallDate, 5, 2) & "/" & Mid(dtmInstallDate, 7, 2) _
'& " " & Mid (dtmInstallDate, 9, 2) & ":" & Mid(dtmInstallDate, 11, 2) & ":" & Mid(dtmInstallDate, 13, 2))
WMIDateStringToDate= dtmInstallDate
'strHTML3 = strHTML3 & "<b>Computer Last Booted </b>: " & WMIDateStringToDate & "<br>"
Next
strHTML2 = "<font face='Arial' size='2' color='white''>"
strComputer = MachineName.Value
strHTML2 = strHTML2 & "<b>Network Adapter Properties</b><br> <br>"
strHTML2 = strHTML2 &"</font><font face='Arial' size='2'>"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
For Each objItem in colItems
strHTML2 = strHTML2 & "<b>Description</b>: " & objItem.Description & "<br>"
strHTML2 = strHTML2 & "<b>Physical (MAC) address</b>: " & objItem.MACAddress & "<br>"
strHTML2 = strHTML2 & "<b>Host name</b>: " & objItem.DNSHostName & "<br>"
If Not IsNull(objItem.IPAddress) Then
For i = 0 To UBound(objItem.IPAddress)
strHTML2 = strHTML2 & "<b>IP address</b>: " & objItem.IPAddress(i) & "<br>"
Next
End If
If Not IsNull(objItem.IPSubnet) Then
For i = 0 To UBound(objItem.IPSubnet)
strHTML2 = strHTML2 & "<b>Subnet</b>: " & objItem.IPSubnet(i) & "<br>"
Next
End If
strHTML2 = strHTML2 & "<b>DHCP server</b>: " & objItem.DHCPServer & "<br>"
strHTML2 = strHTML2 & "<b>Primary WINS server</b>: " & objItem.WINSPrimaryServer & "<br>"
strHTML2 = strHTML2 & "<b>Secondary WINS server</b>: " & objItem.WINSSecondaryServer & "<br> <br>"
Next
DataArea.InnerHTML = strHTML & strHTML4 & strhtml3 & strhtml2
End Sub
Next code snippet with proper error handling could help:
Sub WindowsLoad1
strHTML = strHTML & "<br>" & "<font face='Arial' size='2' color='white''>"
strComputer = MachineName.Value
strHTML = strHTML & "<b>Sys Info</b><br> <br>"
strHTML = strHTML & "</font><font face='Arial' size='2'>"
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
If Err.Number = 0 Then
On Error Goto 0
Else
msgbox "Data for current computer displayed due to the error: " _
& Err.Description _
, vbOKOnly + vbExclamation _
, "An error occured"
On Error Goto 0
strComputer = "."
MachineName.Value = strComputer
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
End If
Set colComputer = objWMIService.ExecQuery ("Select * from Win32_ComputerSystem")
'''''''''''''''''''
' etc.
'''''''''''''''''''
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>
I'm trying to create an HTA To Do List saving locally to a text file. Every time you press submit button generates a new entry that display inside hta body and it's being saved inside the text file. I want to develop this furthermore :
delete an entry and update body/text file
modify an entry and update body/text file
put new entry on top
Any suggestions?
<html>
<head>
<HTA:APPLICATION SINGLEINSTANCE="yes" APPLICATIONNAME="To Do List">
</head>
<SCRIPT Language="VBScript">
Sub Window_OnLoad
ReadBlog
End Sub
Sub SaveData
strDel1="<"
strDel2=">"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists("C:\Test.txt") Then
Set objFile = objFSO.OpenTextFile("C:\Test.txt", 8)
strLine = strDel1 & Time & vbTab & Date & vbTab & Title.Value & vbTab & Message.Value & strDel2
objFile.WriteLine strLine
objFile.Close
Else
Set objFile = objFSO.CreateTextFile("C:\Test.txt")
strLine = strDel1 & Time & vbTab & Date & vbTab & Title.Value & vbTab & Message.Value & strDel2
objFile.WriteLine strLine
objFile.Close
End If
ReadBlog
ClearText
End Sub
Sub ReadBlog
Const ForReading = 1, ForWriting = 2
dim sampletext, objRegExp, SearchPattern, ReplacePattern, matches
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("C:\Test.txt", ForReading)
Do Until objFile.AtEndOfStream
sampletext = objFile.ReadAll
SearchPattern = "<"
SearchPattern = SearchPattern & "(.*?)([\s\S]*?)"
SearchPattern = SearchPattern & ">"
Set objRegExp = New RegExp
objRegExp.Pattern = searchpattern ' apply the search pattern
objRegExp.Global = True ' match all instances if the serach pattern
objRegExp.IgnoreCase = True ' ignore case
Set matches = objRegExp.execute(sampletext)
If matches.Count > 0 Then ' there was at least one match to the search pattern
i=0
For Each match in matches
arrEntry = Split(Split(match.Value, "<")(1), ">")(0)
arrFields = Split(arrEntry, vbTab)
strTime = arrFields(0)
strDate = arrFields(1)
strTitle = arrFields(2)
strMessage = arrFields(3)
strHTML = strHTML & "<p>" & strTime & "</p>"
strHTML = strHTML & "<p>" & strDate & "</p>"
strHTML = strHTML & "<p>" & strTitle & "</p>"
strHTML = strHTML & "<p>" & strMessage & "</p>"
strHTML = strHTML & "<input type='button' name='Delete' value='Delete' >"& i &"<p>"
i=i+1
Next
Else ' there were no matches found
MsgBox objRegExp.Pattern & "was not found in the string"
End If
Loop
DataArea.InnerHTML = strHTML
Set objRegExp = Nothing
Set objFSO = Nothing
End Sub
Sub ClearText
Title.Value = ""
Message.Value = ""
End Sub
</SCRIPT>
<body>
<input type="text" name="Title" size="101"><p>
<textarea rows="10" cols="76" type="text" name="Message" size="25"></textarea><p>
<input type="button" value="Submit" onClick="SaveData">
<p><div id="DataArea"></div></p>
</body>
</html>
Are you particularly tied to using text files? If you used a database (such as access) you could do this quite easily (you don't have to have access installed to use an access database with an HTA either). And it would open up some other possibilities.
Incidentally, I also notice you're doing this:
strHTML = strHTML & "<p>" & strTime & "</p>"
strHTML = strHTML & "<p>" & strDate & "</p>"
strHTML = strHTML & "<p>" & strTitle & "</p>"
strHTML = strHTML & "<p>" & strMessage & "</p>"
Not a big thing, but concatenating the strings like that isn't great for performance. You'd be better off writing it all to the variable at the same time, otherwise it has to keep writing the variable to memory over and over again.
If you want to read a file with HTA you can easily do it in javaScript. Since the context changes IE allws you to directly read file on the computer or the network to wich the computer is linked to. In order to do so, you need to access the File System Object (FSO)
Full Documentation on FSO
If you are still looking to access a database you need to use the ADODB.Connection. That will allow you to connect to database localy or remotely. Altought there is not much documentation on the subject we did it at my work place. With a little imagination you can figure out how to fix it.
Documentation on the ADODB.Connnect
In this documentation the example are in VB but you can write them in JS as well.