Solved

Dynamic VBScript Search Based on Multiple Values

Posted on 2013-06-04
28
418 Views
Last Modified: 2013-06-19
This question spawns from the question below.  In the previous question, I asked to have a dropdown box's source to be from a specified excel spreadsheet.  Now I am in need of making the search function to look based on if one or the other fields have a value.  Currently, the dropdown shows the very first value from the source (excel spreadsheet column), but I would like for it to default to blank.  This would allow a search for IF the dropdown has a value and the textbox does not, THEN search based on the dropdown.  OR IF the dropdown does NOT have a value and the textbox does, THEN search based on the textbox.  Is this possible?  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 

  LoadDropDown 
	
  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 1150,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 - 1150) / 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 VendorName
	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 Name] =""" & Optionchooser.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

Sub LoadDropDown
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 ClearListbox
    For Each objOption in OptionChooser.Options
       objOption.RemoveNode
    Next
End Sub

Sub DecideSearch
	If txtFilter.value = "" THEN
	 	VendorName
	Else
		ReturnRows
	End if
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 Criteria:</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="LoadDropDown"></select>

<br><br>
<input id=runbutton  class="button" type="button" value="Search" name="run_button"  onClick="DecideSearch" title="Click here to search specific values.">
<input id=runbutton  class="button" type="button" value="Fuzzy Search" name="run_button"  onClick="FuzzySearch" title="Click here to search partial values.">
<input id=runbutton  class="button" type="button" value="Refresh" name="run_button"  onClick="RunScript" title="Click here to refresh page.">
<br>
</fieldset>
<hr>
<span id=DataArea></span>
<span id=msg style="z-Index:10"></span> 
</body> 
</html>

Open in new window

0
Comment
Question by:Christopher Wright
  • 15
  • 10
28 Comments
 

Author Comment

by:Christopher Wright
ID: 39235728
Is there anyone out there to support me?  Please?
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39250697
My apologies-.-I'd been meaning to look at this for you. I know the question has been closed but did you find a solution? If not I can try to help
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39251911
Can you post your spreadsheet or a sample spreadsheet if the info is too sensitive to post online?  Would save some time.
0
 

Author Comment

by:Christopher Wright
ID: 39251967
I have attached a sample spreadsheet. Thanks
Daily-Stocking-Position-Test-Dat.xlsx
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39252135
Ok I've had a look and what you're suggesting is possible.  You can set the drop down to a blank or "-- Select Vendor ---" just by adding it before you loop through the results from the spreadsheet in your sub LoadDropDown

eg.

Sub LoadDropDown
Dim Rs, cn, objOption 
  
	Set Rs = CreateObject("ADODB.Recordset")
	Set cn = CreateObject("ADODB.connection")
	cn.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dataSrc & ";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

' add a blank
	Set objOption = Document.createElement("OPTION")
	objOption.Text = ""
	objOption.Value = -1
	OptionChooser.Add(objOption)

    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

Open in new window


I'll look further into how you've done the search and explain what needs to be done there
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39252138
I meant to ask what you want to happen if something is typed into the textbox AND there is something selected in your dropdown?
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39252204
Ok I've made a few mods for you but I'm still waiting on your reply re what to do when both the dropdown and the textbox are filled

<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 

  LoadDropDown 
	
  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 1150,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 - 1150) / 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

' fields for connection string
Dim dataSrc

'dataSrc = "I:\Chris Wright\Chris Wright\Daily Reports\Stock Position Reports\Daily Stocking Position.xlsx"
dataSrc = "c:\users\rob\documents\ee\hta\Daily-Stocking-Position-Test-Dat.xlsx"

' Perform an exact search
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=" & dataSrc & ";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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		end if
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop
	DataArea.InnerHTML = strData & "</table>"
end Sub

sub VendorName
	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=" & dataSrc & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"  'Persist Security Info=False;"
	cn.Open
	Rs.Open "Select * from [VPN Position$] Where [Vendor Name] =""" & Optionchooser.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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		End If
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop

	DataArea.InnerHTML = strData & "</table>"
End Sub

Sub DecideSearch
	' txtFilter is PART NUMBER
	' OptionChooser is VENDOR
	
	' Search the vendor if the part number is empty and a Vendor has been selected
	If txtFilter.value = "" AND OptionChooser.SelectedIndex > 0 THEN
	 	VendorName
	Else
		ReturnRows
	End if
End Sub

Sub FuzzySearch
	' Search the vendor if the part number is empty and a Vendor has been selected
	' Also do not search if both are empty
	If txtFilter.value = "" AND OptionChooser.SelectedIndex > 0 THEN
	 	VendorName
	ElseIf txtFilter.value <> "" Then
		FuzzySearchGo
	End if
End Sub

Sub FuzzySearchGo
	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=" & dataSrc & ";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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		end if
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop
	DataArea.InnerHTML = strData & "</table>"
end sub

'============================================

Sub LoadDropDown
Dim Rs, cn, objOption 
  
	Set Rs = CreateObject("ADODB.Recordset")
	Set cn = CreateObject("ADODB.connection")
	cn.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dataSrc & ";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

' add a blank
	Set objOption = Document.createElement("OPTION")
	objOption.Text = ""
	objOption.Value = -1
	OptionChooser.Add(objOption)

    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 ClearListbox
    For Each objOption in OptionChooser.Options
       objOption.RemoveNode
    Next
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 Criteria:</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="LoadDropDown"></select>

<br><br>
<input id="runbutton1"  class="button" type="button" value="Search" name="run_button"  onClick="DecideSearch" title="Click here to search specific values.">
<input id="runbutton2"  class="button" type="button" value="Fuzzy Search" name="run_button"  onClick="FuzzySearch" title="Click here to search partial values.">
<input id="runbutton3"  class="button" type="button" value="Refresh" name="run_button"  onClick="RunScript" title="Click here to refresh page.">
<br>
</fieldset>
<hr>
<span id=DataArea></span>
<span id=msg style="z-Index:10"></span> 
</body> 
</html>

Open in new window

0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39252205
I also had to modify where the spreadsheet was (as i don't have an I drive...)

See line 271 to comment out my path and uncomment yours

I was also getting a few weird errors around the data coming back from Excel and VBS not liking it.  Were you getting these errors?  I've got around it with the "On Error Resume Next" that you'll see in the search subs.  Doesn't seem to affect the data displayed as I checked it against the spreadsheet.
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39252206
As for your original question about the search function IF .. ELSE  etc, I achieved that by using the selectedIndex property of the SELECT object.  Told it to ignore the first element in the dropdown (as it's blank).

I created a wrapper for your fuzzy search "FuzzySearchGo" to be able to integrate the IF ELSE logic you are after.  I added an ElseIf to that fuzzy search so that it would do nothing when both search fields were empty otherwise it would bring back the entire spreadsheet's data.

The code can certainly be improved but I don't think that's necessary unless you notice weird behaviour or performance issues.
0
 

Author Comment

by:Christopher Wright
ID: 39254623
Please forgive me for the delay tagit.  It has been a busy day and did not have the chance to check up on this question today. As pertaining to your question in Thread ID: 39252138, if a user has information in both the dropdown and the text, can the search be filtered based on both values?

I appreciate your help with this.  You state in your last thread that the code can be improved; if you don't mind, what can I do to improve it?  I want to learn where I can be better when it comes to this.  Thank you for your help again! God bless!
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39254880
Yes the search can be filtered by both for both an exact and fuzzy search. That would make the most sense for someone using it.
As for the code I'll give you my recommendations soon
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39255193
This works for exact search, fuzzy search if both fields are populated

<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 

  LoadDropDown 
	
  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 1150,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 - 1150) / 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

' fields for connection string
Dim dataSrc

'dataSrc = "I:\Chris Wright\Chris Wright\Daily Reports\Stock Position Reports\Daily Stocking Position.xlsx"
dataSrc = "c:\users\rob\documents\ee\hta\Daily-Stocking-Position-Test-Dat.xlsx"

' Perform an exact search
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=" & dataSrc & ";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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		end if
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop
	DataArea.InnerHTML = strData & "</table>"
end Sub

sub VendorName
	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=" & dataSrc & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"  'Persist Security Info=False;"
	cn.Open
	Rs.Open "Select * from [VPN Position$] Where [Vendor Name] =""" & Optionchooser.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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		End If
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop

	DataArea.InnerHTML = strData & "</table>"
End Sub

Sub Combination
	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=" & dataSrc & ";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 & "' AND [Vendor Name] =""" & Optionchooser.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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		End If
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop

	DataArea.InnerHTML = strData & "</table>"
End Sub

Sub DecideSearch
	' txtFilter is PART NUMBER
	' OptionChooser is VENDOR
	
	' Search the vendor if the part number is empty and a Vendor has been selected
	If txtFilter.value = "" AND OptionChooser.SelectedIndex > 0 Then
	 	VendorName
	ElseIf txtFilter.value <> "" AND OptionChooser.SelectedIndex = 0 Then
		ReturnRows
	Else
		' Search based on a combination of the two
		Combination
	End if
End Sub

Sub FuzzySearch
	' Search the vendor if the part number is empty and a Vendor has been selected
	' Also do not search if both are empty
	If txtFilter.value = "" AND OptionChooser.SelectedIndex > 0 THEN
	 	VendorName
	ElseIf txtFilter.value <> "" Then
		FuzzySearchGo
	Else
		CombinationFuzzy
	End if
End Sub

Sub FuzzySearchGo
	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=" & dataSrc & ";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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		end if
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop
	DataArea.InnerHTML = strData & "</table>"
End Sub

Sub CombinationFuzzy
	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=" & dataSrc & ";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 & "%' AND [Vendor Name] =""" & Optionchooser.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
			On Error Resume Next
			strRow = strRow & "<td>" & fld.value & "</td>"
			On Error Goto 0
		End If
	  Next
	  strData = strData & strRow & "</tr>"
	  Rs.MoveNext
	Loop

	DataArea.InnerHTML = strData & "</table>"
End Sub

'============================================

Sub LoadDropDown
Dim Rs, cn, objOption 
  
	Set Rs = CreateObject("ADODB.Recordset")
	Set cn = CreateObject("ADODB.connection")
	cn.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dataSrc & ";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

' add a blank
	Set objOption = Document.createElement("OPTION")
	objOption.Text = ""
	objOption.Value = -1
	OptionChooser.Add(objOption)

    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 ClearListbox
    For Each objOption in OptionChooser.Options
       objOption.RemoveNode
    Next
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 Criteria:</legend></b><p>
<b>Part Number: </b> <input type="text" name="txtFilter" size="40"><br><br>
<b>Vendor Name: <select size="1" name="OptionChooser"></select>

<br><br>
<input id="runbutton1"  class="button" type="button" value="Search" name="run_button"  onClick="DecideSearch" title="Click here to search specific values.">
<input id="runbutton2"  class="button" type="button" value="Fuzzy Search" name="run_button"  onClick="FuzzySearch" title="Click here to search partial values.">
<input id="runbutton3"  class="button" type="button" value="Refresh" name="run_button"  onClick="RunScript" title="Click here to refresh page.">
<br>
</fieldset>
<hr>
<span id=DataArea></span>
<span id=msg style="z-Index:10"></span> 
</body> 
</html>

Open in new window

0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 42

Accepted Solution

by:
Rob Jurd, EE MVE earned 500 total points
ID: 39255209
I have also removed the
 onChange="LoadDropDown"

Open in new window

from the dropdown... not sure why you have this.  It makes it really slow when you change the selection.

My points about your code:
Code reuse as you are repeating code such as for the results.  You could combine the common code into a single Sub/Function so that if you need to change something you only need to do it once rather than everywhere you have it now.  eg changing the way the results are displayed you would have to change this is every search Sub
I would have all the vb code and CSS in external files and linked into the hta document.  This makes it easier to look through the code
while we're on that, I would also break down the vb code into multiple vbs files based on what they logically do
Another important point is to comment your code.  You'll always forget what each part of the code means.  I would also give your functions and variables meaningful names so you know what they do without looking too far into them
0
 

Author Closing Comment

by:Christopher Wright
ID: 39256880
I am so grateful for your help and guidance with this tagit.  I sincerely mean that.  You have been a great resource and teacher.  Thank you again and God bless you!!
0
 

Author Comment

by:Christopher Wright
ID: 39256890
That makes a lot of sense, and I agree with you one hundred percent.  Thank you again for your help and patience tagit.  


BTW, would you be interested in helping me with another endeavor related to this?  Thanks
0
 

Author Comment

by:Christopher Wright
ID: 39257372
Quick follow up question tagit, is there a way for my users to access this?  I sent it out to a few users and they are getting the error below:

Error Message
Please help. Thanks
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39257959
Do you have any more details about the computers they're running it on and more specifically what version of IE they're running?
Are they in the office with you or remote?
0
 

Author Comment

by:Christopher Wright
ID: 39257983
98% of my users are in the office with me.  We only have a handful of remote users.  Unfortunately, not everyone is running IE.  Of course many are, and they are running IE8, 9, and 10.  Many user Chrome and Mozilla Firefox as well.  What can be done to get around this?  Thanks tagit!!!
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39258000
No problem :)

It's more what version of IE is installed whether they use it or not.  HTA renders the page using IE and I'm looking for a correlation between the users having issues and the version of IE they're running.  At least as a start to debug your problem.

Is there anything unique about those users machines that are having the problem?

I would also check internet settings to see if scripting is enabled (http://www.ehow.com/how_8791002_enable-vbscript.html)

What version of the hta did you send them?  The one I posted or another modified one?
0
 

Author Comment

by:Christopher Wright
ID: 39259846
Nothing unique that I can think of.  Most are using Windows 2007.  Some have been upgraded to 2010 but nothing out of the ordinary.  

I sent your version except I commented out the address you had and uncommented mine.  That's the only modification I made.  

I took a look at the link you provided.  It gives instruction on going and manually enabling VBScript.  I know this may be a touchy subject, but is there any way I can have it auto enable for my users.  Basically, the script would be enabled programmatically.  Is this possible?

Thanks again tagit!  God bless!!
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39261184
I think you're referring to office not Windows when you say they are on 2007 and some upgraded to 2010. As for their Windows versions are they running XP, Vista, Windows 7, Windows 8? ? It's actually the version of Internet Explorer I'm interested in.
The only way that may work to enable scripting is by domain security policies. Are these computers part of your domain?
0
 

Author Comment

by:Christopher Wright
ID: 39261234
Yes they are part of the same domain. My apologies for the confusion. The versions of Windows varies between XP and Windows 7.  All are running. 32bit as well.
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39261357
No problem at all.  Is it the XP computers that are having the issues?

Have you used group policy before?  Here is a link to forcing domain wide disabling of scripting but the opposite is true to enable it

http://www.zdnet.com/blog/ou/stop-ie-active-scripting-for-all-computers-in-a-domain/132
0
 

Author Comment

by:Christopher Wright
ID: 39261494
I've ran this on an XP with no issue.  The other was ran with windows 7 and had issues.
0
 
LVL 42

Expert Comment

by:Rob Jurd, EE MVE
ID: 39261577
check the windows 7 pc doesn't have active scripting disabled.  see above link for how to enable
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

Have you tried to learn about Unicode, UTF-8, and multibyte text encoding and all the articles are just too "academic" or too technical? This article aims to make the whole topic easy for just about anyone to understand.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This is Part 3 in a 3-part series on Experts Exchange to discuss error handling in VBA code written for Excel. Part 1 of this series discussed basic error handling code using VBA. http://www.experts-exchange.com/videos/1478/Excel-Error-Handlin…

760 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

16 Experts available now in Live!

Get 1:1 Help Now