Solved

Populate an HTA Drop Down List with Closed Excel Range

Posted on 2013-05-25
25
1,034 Views
Last Modified: 2013-06-04
Greetings Everyone.  For starters, I am total newbie here, so please don't crack on me too hard for the horrible scripting techniques.  I created the attached HTA with simple trial and error, sweat and tears but I need help now.  How can I have this HTA have the functionality to search by specific part number.  I have also provided a "fuzzy search" as well.  I want to provide the functionality to search by a specific vendor name as well. The list of vendor names would be found in the drop down list.  I also want to further develop this to include animated charts and graphs for other data sets but for now, I simply want to populate the drop down and enable the search.  Please help anyone!  Thanks EE.


<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=vbs>  
' 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 = "&nbsp;&nbsp;&nbsp;#sItem#&nbsp;&nbsp;&nbsp;" 
 
Dim dMenus, sMenuOpen 
 
sub Window_onload 
Dim entry 
  set dMenus = createObject("Scripting.Dictionary") 
  for each entry in Split(sMenuItems, ",") 
    menu.innerHTML = menu.innerHTML & "&nbsp;<span id=" & entry _ 
                   & " style='padding-bottom:2px' onselectstart=cancelEvent>&nbsp;" _ 
                   & entry & "&nbsp;</span>&nbsp;&nbsp;" 
    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 TestSub
  If OptionChooser.Value <> 0 Then
     Msgbox "You selected Option " & OptionChooser.Value & "."
  End If
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 = "Cat Code" 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">
    <option value="0"></option>
    <option value="1">3M</option>
    <option value="2">ACR ELECTRONICS  INC</option>
    <option value="3">ADVENTURE LIGHTS</option>
</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>

Open in new window

Test-Portal.txt
0
Comment
Question by:Christopher Wright
  • 12
  • 12
25 Comments
 

Author Comment

by:Christopher Wright
ID: 39197082
Oops sorry.  I did not attach the spreadsheet sample.  Thanks again.
Daily-Stocking-Position.xlsx
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39197612
Do you need to populate from the Position worksheet or the Sales History (Stock) worksheet?
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39197634
First part is to remove your hard-coded vendor names.
This
<select size="1" name="OptionChooser" onChange="TestSub">
    <option value="0"></option>
    <option value="1">3M</option>
    <option value="2">ACR ELECTRONICS  INC</option>
    <option value="3">ADVENTURE LIGHTS</option>
</select>

Open in new window

becomes this:
<select size="1" name="OptionChooser" onChange="TestSub"></select>

Open in new window


Population the dropdown would happen in manner similar to what you are already doing with the other ADO reading of worksheet data.
	Dim Rs, cn, 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"";"  'Persist Security Info=False;"
	cn.Open
	Rs.Open "Select Distinct [Vendor Name] from [Sales History (Stock)$], cn, 1, 3

    Do Until rs.EOF
	Set objOption = Document.createElement("OPTION")
	objOption.Text = rs![Vendor Name]
	objOption.Value = rs![Vendor Name]
	OptionChooser.Add(objOption)
	rs.MoveNext
    Loop

Open in new window

0
 

Author Comment

by:Christopher Wright
ID: 39198296
Greetings aikimark.  I made the adjustments but am getting a couple of errors.  Whenever I open the HTA, I get this error message:
First Error Message
From here, I click 'Yes' and then get the error message below.  This error message continually pops up over and over.
Second Error Message
The modified script is below.  Thanks

<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=vbs>  
' 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 = "&nbsp;&nbsp;&nbsp;#sItem#&nbsp;&nbsp;&nbsp;" 
 
Dim dMenus, sMenuOpen 
 
sub Window_onload 
Dim entry 
  set dMenus = createObject("Scripting.Dictionary") 
  for each entry in Split(sMenuItems, ",") 
    menu.innerHTML = menu.innerHTML & "&nbsp;<span id=" & entry _ 
                   & " style='padding-bottom:2px' onselectstart=cancelEvent>&nbsp;" _ 
                   & entry & "&nbsp;</span>&nbsp;&nbsp;" 
    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 TestSub
Dim Rs, cn, 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"";"  'Persist Security Info=False;"
	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![Vendor Name]
	objOption.Value = rs![Vendor Name]
	OptionChooser.Add(objOption)
	rs.MoveNext
    Loop  
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>

Open in new window

0
 
LVL 45

Expert Comment

by:aikimark
ID: 39198488
The SQL String I posted is missing a closing quote character.
0
 

Author Comment

by:Christopher Wright
ID: 39199821
Roger that.  Please forgive me.  I should have caught that.  Another issue, how can I avoid the error message below from populating with every action performed with the HTA.

ADO Security Warning Message
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39199833
If you are mapping a drive letter, I don't see why you are receiving that message.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39199837
What is in your Trusted Sites list in IE?
0
 

Author Comment

by:Christopher Wright
ID: 39199931
I don't think I have any.  Would all users have to add this to their Trusted Sites list or can that be accomplished programmatically? Thanks aimark.

Trusted Sites
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39200174
1. I generally uncheck the https requirement.
2. You should be able to implement the trusted sites through AD group policies.
0
 

Author Comment

by:Christopher Wright
ID: 39203109
I browsed around in my AD Group policies but what specifically should I be modifying.  Also, I still have not been able to get the script to run without the same errors, even after adding the missing quotes to terminate the sql statement.  Please help.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39203134
What error(s) are you seeing?
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

by:Christopher Wright
ID: 39209586
I'm getting the exact same errors.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39210451
I'm getting the exact same errors.

When I asked "what errors", I needed you to be specific about the errors.  You reported an error with my SQL string that I thought you had corrected.

If you are including the security dialog to be an error, you need to state that explicitly.  I do not consider a security warning to be an error.
0
 

Author Comment

by:Christopher Wright
ID: 39212084
My apologies.  I am getting the same errors specified in Thread ID ID: http:#a39198296 .
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39212094
Try this.
<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=vbs>  
' 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 = "&nbsp;&nbsp;&nbsp;#sItem#&nbsp;&nbsp;&nbsp;" 
 
Dim dMenus, sMenuOpen 
 
sub Window_onload 
Dim entry 
  set dMenus = createObject("Scripting.Dictionary") 
  for each entry in Split(sMenuItems, ",") 
    menu.innerHTML = menu.innerHTML & "&nbsp;<span id=" & entry _ 
                   & " style='padding-bottom:2px' onselectstart=cancelEvent>&nbsp;" _ 
                   & entry & "&nbsp;</span>&nbsp;&nbsp;" 
    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 TestSub
Dim Rs, cn, 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  
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>

Open in new window

0
 

Author Comment

by:Christopher Wright
ID: 39213694
Now I am getting the error below when I open the hta...

Msg Box
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39213743
that error is in your code, not mine
0
 

Author Comment

by:Christopher Wright
ID: 39214676
Where would I need to start looking then?  Like I said, I am a total noob here, so what do you think the error is?  Maybe I am wrong, but would this be in the Window_onload event?  I'm sorry if I have not been the most resourceful or helpful but I really am in need of Expert help here.  Please let me know what I can do to help...?
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39214858
use Notepad and turn on the status bar to help you navigate the source code.  Comment out the statement highlighted in the error message and rerun the script.
0
 

Author Comment

by:Christopher Wright
ID: 39218771
Thanks Aikmark, I ironed out my code for the Window_onload.  I am still not getting values in the drop-down however.  It doesn't produce an error but simple gives a blank drop-down.  Is there something missing??  The data being pulled (in the Vendor Name Column has mixed data formats-numbers).  The code is below.  Thanks

<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 = "&nbsp;&nbsp;&nbsp;#sItem#&nbsp;&nbsp;&nbsp;" 
 
Dim dMenus, sMenuOpen 
 
sub Window_onload 
Dim entry 
  set dMenus = createObject("Scripting.Dictionary") 
  for each entry in Split(sMenuItems, ",") 
    menu.innerHTML = menu.innerHTML & "&nbsp;<span id=" & entry _ 
                   & " style='padding-bottom:2px' onselectstart=cancelEvent>&nbsp;" _ 
                   & entry & "&nbsp;</span>&nbsp;&nbsp;" 
    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 TestSub
  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 "SQL Select Distinct [Vendor Name] from [VPN Position$]", cn, 3, 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  
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>

Open in new window

0
 
LVL 45

Accepted Solution

by:
aikimark earned 500 total points
ID: 39218793
The testsub() routine needs to be invoked during initialization and not during the OptionChooser OnChange event.
0
 

Author Comment

by:Christopher Wright
ID: 39218828
You rock!!!  Thank you so much aikmark.  I am going to be asking another question relating to this code after I close this one out, would you be willing to help out?  Thanks again sir!
0
 

Author Closing Comment

by:Christopher Wright
ID: 39218833
Great help and a lot learned from this.  Thanks
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Suggested Solutions

Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
Over the years I have built up my own little library of code snippets that I refer to when programming or writing a script.  Many of these have come from the web or adaptations from snippets I find on the Web.  Periodically I add to them when I come…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now