Adding Charts and Graphs to HTA
I currently have an HTA which searches for specific item numbers or Vendor Name. I am curious if it is possible to have the ability to show historical trends in data by using a line chart and or how many items a vendor has as compared to the total with maybe a pie chart. Is this possible? The code is below:
<html>
<head>
<HTA:APPLICATION
APPLICATIONNAME="Purchasing Portal"
ID="Purchasing Portal"
border="normal"
borderStyle="normal"
caption="yes"
icon="I:\BI-CEW\favicon2.ico"
maximizeButton="yes"
minimizeButton="yes"
showInTaskbar="no"
windowState="normal"
innerBorder="yes"
navigable="yes"
scroll="auto"
SINGLEINSTANCE="yes"
scrollFlat="yes" />
<br>
<title>Purchasing Portal -- Presented by ADS Solutions</title>
<center>
<TABLE BORDER="1" WIDTH="1000"><TR><TD>
<center><u><H1>Inventory Stock Position</H1></u></center>
<hr>
</center>
</head>
<style>
BODY
{
background-color: Gainsboro;
font-family: Cambria;
font-size: 12pt;
margin-top: 30px;
margin-left: 5px;
margin-right: 5px;
margin-bottom: 30px;
}
button
{
background-color: Steelblue;
font-family: Cambria;
font-size: 12pt;
width: 100px;
margin-left: 0px;
}
textarea
{
color: white;
font-family: Cambria;
font-size: 11pt;
}
select
{
font-family: Cambria;
font-size: 10pt;
width: 300px;
margin-left: 0px;
}
td
{
color: default;
font-family: Cambria;
font-size: 11pt;
}
</style>
<script language=VBScript>
' Copyright 2013, Chris Wright, cwright at adsinc dot com
' Define menu items
Const sMenuItems = "File,Edit,Help"
' Define one submenu constant for each menu item as illustrated below
' Each is a comma separated list in a single string
Const sFile = "Open,Close,Save,Save As ...,Exit"
Const sEdit = "Cut,Copy,Paste,Select All,Deselect All"
Const sHelp = "Help, About"
Const sHTML = " #sItem# "
Dim dMenus, sMenuOpen
sub Window_onload
Dim Rs
Dim cn
Dim objOption
Set Rs = CreateObject("ADODB.Recordset")
Set cn = CreateObject("ADODB.connection")
cn.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=I:\Chris Wright\Chris Wright\Daily Reports\Stock Position Reports\Daily Stocking Position.xlsx;Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
cn.Open
Rs.Open "Select Distinct [Vendor Name] from [VPN Position$]", cn, 1, 3
Do Until rs.EOF
Set objOption = Document.createElement("OPTION")
objOption.Text = rs.fields("Vendor Name")
objOption.Value = rs.fields("Vendor Name")
OptionChooser.Add(objOption)
rs.MoveNext
Loop
Dim entry
set dMenus = createObject("Scripting.Dictionary")
for each entry in Split(sMenuItems, ",")
menu.innerHTML = menu.innerHTML & " <span id=" & entry _
& " style='padding-bottom:2px' onselectstart=cancelEvent> " _
& entry & " </span> "
dMenus.Add entry, Split(eval("s" & entry), ",")
next
sMenuOpen = ""
window.resizeTo 1125,600
strComputer = "."
Set objWMIService = GetObject("Winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * From Win32_DesktopMonitor")
For Each objItem in colItems
intHorizontal = objItem.ScreenWidth
intVertical = objItem.ScreenHeight
Next
intLeft = (intHorizontal - 1125) / 2
intTop = (intVertical - 600) / 2
window.moveTo intLeft, intTop
end sub
Sub menu_onmouseover
clearmenu
with window.event.srcElement
if .parentElement.ID = "menu" then
.style.border = "thin outset"
.style.cursor = "arrow"
end if
end with
end sub
Sub menu_onmouseout
with window.event.srcElement
.style.border = "none"
.style.cursor = "default"
end with ' srcElement
end sub
Sub dropmenu_onmouseover
with window.event
.srcElement.style.cursor = "arrow"
.cancelbubble = true
.returnvalue = false
end with
end sub
sub SubMenuOver
with window.event.srcElement
if .ID = "dropmenu" then exit sub
.style.backgroundcolor = "darkblue"
.style.color = "white"
.style.cursor = "arrow"
end with
end sub
sub SubMenuOut
with window.event.srcElement
.style.backgroundcolor = "lightgrey"
.style.color = "black"
.style.cursor = "default"
end with
end sub
Sub menu_onclick
Dim oEL, oItem
if sMenuOpen <> "" then exit sub
with window.event.srcElement
if .ID <> "menu" then
.style.border = "thin inset"
nLeft = .offsetLeft
ntop = .offsetTop + replace(menu.style.Height, "px", "") - 5
sMenuOpen = trim(.innertext)
with dropmenu
with .style
.border = "thin outset"
.backgroundcolor = "lightgrey"
.position = "absolute"
.left = nLeft
.top = nTop
.width = "100px"
.zIndex = "101"
end with ' style
for each sItem in dMenus.Item(sMenuOpen)
set oEL = document.createElement("SPAN")
.appendChild(oEL)
with oEl
.ID = sItem
.style.height = "20px"
.style.width = dropmenu.style.width
.style.zIndex = "102" ' added 28 June 2010
.innerHTML = Replace(sHTML, "#sItem#", trim(sItem))
set .onmouseover = getRef("SubMenuOver")
set .onmouseout = getRef("SubMenuOut")
set .onclick = getRef("SubMenuClick")
set .onselectstart = getRef("cancelEvent")
end with ' child node
set oEL = document.createElement("BR")
.appendChild(oEL)
next
end with ' dropmenu
end if
end with ' srcEement
end sub
sub cancelEvent
window.event.returnValue = false
end sub ' cancelEvent
sub clearmenu
dropmenu.innerHTML = ""
dropmenu.style.border = "none"
dropmenu.style.backgroundcolor = "transparent"
if sMenuOpen <> "" then
document.getElementByID(sMenuOpen).style.border = "none"
sMenuOpen = ""
end if
end sub
' ################### IMPORTANT ###################
' Code to accomplish each submenu item defined above
' Can be as simple as a subroutine call
'
Sub SubMenuClick
sItem = trim(window.event.srcElement.innerText)
clearmenu
Select Case lcase(sItem)
case "open"
msgbox "Sorry, " & sItem & " is not implemented"
case "close"
msgbox "Sorry, " & sItem & " is not implemented"
case "save"
msgbox "Sorry, " & sItem & " is not implemented"
case "save as ..."
msgbox "Sorry, " & sItem & " is not implemented"
case "exit"
window.close
case "cut"
msgbox "Sorry, " & sItem & " is not implemented"
case "copy"
case "paste"
msgbox "Sorry, " & sItem & " is not implemented"
case "select all"
msgbox "Sorry, " & sItem & " is not implemented"
case "deselect all"
msgbox "Sorry, " & sItem & " is not implemented"
case "help"
msgbox "Help under construction", vbOKOnly + vbInformation, "Help"
case "about"
msgbox "Copyright, 2013" & vbCRLF & "Chris wright"_
& vbCRLF & "Released for Purchasing Only",_
vbOKOnly + vbInformation, "About Menu"
case else ' catch all for undefined menu items
msgbox "Sorry, " & sItem & " is not implemented"
end Select
end sub
Sub RunScript
Location.Reload(True)
End Sub
sub ReturnRows
Dim cn
Dim Rs
Dim strData
Dim strRow
Dim fld
Set Rs = CreateObject("ADODB.Recordset")
Set cn = CreateObject("ADODB.connection")
cn.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=I:\Chris Wright\Chris Wright\Daily Reports\Stock Position Reports\Daily Stocking Position.xlsx;Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";" 'Persist Security Info=False;"
cn.Open
Rs.Open "Select * from [VPN Position$] Where [Vendor Part Number] =""" & txtFilter.value & """", cn, 1, 3
strData = "<table width=""100%"" border=""2"" cellpadding=""1""<caption>Results:</caption"">"
if not rs.eof then
strData = strData & "<tr>"
strRow = ""
For each fld in rs.fields
strRow = strRow & "<th>" & fld.name & "</th>"
Next
strData = strData & strRow & "</tr>"
end if
do until Rs.EOF
strRow = "<tr>"
For Each fld in Rs.Fields
if fld.name = "MAX Ordered Qty" then
strRow = strRow & "<td class=""mono"">" & fld.value & "</td>"
else
strRow = strRow & "<td>" & fld.value & "</td>"
end if
Next
strData = strData & strRow & "</tr>"
Rs.MoveNext
Loop
DataArea.InnerHTML = strData & "</table>"
end sub
sub FuzzySearch
Dim cn
Dim Rs
Dim strData
Dim strRow
Dim fld
Set Rs = CreateObject("ADODB.Recordset")
Set cn = CreateObject("ADODB.connection")
cn.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=I:\Chris Wright\Chris Wright\Daily Reports\Stock Position Reports\Daily Stocking Position.xlsx;Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";" 'Persist Security Info=False;"
cn.Open
Rs.Open "Select * from [VPN Position$] Where [Vendor Part Number] Like '%" & txtFilter.value & "%'", cn, 1, 3
strData = "<table width=""100%"" border>"
if not rs.eof then
strData = strData & "<tr>"
strRow = ""
For each fld in rs.fields
strRow = strRow & "<th>" & fld.name & "</th>"
Next
strData = strData & strRow & "</tr>"
end if
do until Rs.EOF
strRow = "<tr>"
For Each fld in Rs.Fields
if fld.name = "MAX Ordered Qty" then
strRow = strRow & "<td class=""mono"">" & fld.value & "</td>"
else
strRow = strRow & "<td>" & fld.value & "</td>"
end if
Next
strData = strData & strRow & "</tr>"
Rs.MoveNext
Loop
DataArea.InnerHTML = strData & "</table>"
end sub
</script>
<!--Page layout follows-->
<body onmouseover=menu_onmouseover style="font:14pt Cambria">
<div id=menu style="position:absolute;left:0;top:0;width:110%;height:23px;
padding-top:2px;background-color:lightgrey;
font:normal 12pt Cambria;z-Index:100">
</div>
<span id=dropmenu style="font:normal 10pt Cambria"></span>
<fieldset>
<b><legend>Search:</legend></b><p>
<b>Part Number: </b> <input type="text" name="txtFilter" size="40"><br><br>
<b>Vendor Name: <select size="1" name="OptionChooser" onChange="TestSub"></select>
<br><br>
<input id=runbutton class="button" type="button" value="Search" name="run_button" onClick="ReturnRows">
<input id=runbutton class="button" type="button" value="Fuzzy Search" name="run_button" onClick="FuzzySearch">
<input id=runbutton class="button" type="button" value="Refresh" name="run_button" onClick="RunScript">
<br>
</fieldset>
<hr>
<span id=DataArea></span>
<span id=msg style="z-Index:10"></span>
</body>
</html>ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
You will have a lot more flexibility to do trending and graphs if you move it to a web app.
What was the reason you decided on a hta?