<% ProductGroup=0 'Based on EPI warehouse codes Product="" Industry=0 'Based on EPI warehouse codes Author="Kwan Kim" Title="Publication XLS download" LastUpdate=#12/05/2005# Country="WW" 'Based on codes in cagmisc.mdb PageType=7 'Based on list maintained by webmaster NavigationOverride=0 'Include left navigation BodyGraphic="" 'Contains main body graphic with banner shadow ExtraNav="" 'HTML for extra navigation buttons below left navigation %> <% If Trim(request("JSearchTimeStamp")) <> Trim(Session("JSearchTimeStamp")) Then response.write "The search results have been expired. Click here for new search." %> <% Else response.clear WriteXLSFile Response.End End If %> <% Sub WriteXLSFile() 'Header treatment Response.Buffer = True Response.ContentType = "application/vnd.ms-excel" Response.AddHeader "content-disposition","attachment; filename=Publication.xls" Dim NumOrders, NumProds, r NumOrders = 300 NumProds = 10 Dim oSS Dim oOrdersSheet Dim oRange Dim c ' Set oSS = CreateObject("OWC11.Spreadsheet.11") ' Set oSS = CreateObject("OWC10.Spreadsheet.10") ' Set oSS = CreateObject("OWC9.Spreadsheet.9") Set oSS = CreateObject("OWC11.Spreadsheet") Set c = oSS.Constants 'Rename Sheet1 and remove Sheet2, Sheet3 Set oOrdersSheet = oSS.Worksheets(1) oOrdersSheet.Name = "Agilent Publications" oSS.Worksheets(2).Delete '=== Build the First Worksheet (Orders) ============================================== 'Add headings to A1:P1 of the Orders worksheet and apply formatting Set oRange = oOrdersSheet.Range("A1:N1") ' oRange.Value = Array("Title", "Authors", "Name", "Year", "Language", "URL", "PubMedURL", "CAS URL", "Abstract URL", "PDF URL", "Volume", "Journal Number", "Abstract", "Pages") oRange.Value = Array("Title", "Authors", "Name", "Year", "Language", "URL", "PubMedURL", "CAS URL", "Abstract URL", "PDF URL", "Volume", "Journal Number", "Abstract", "Pages") oRange.Font.Bold = True oRange.Interior.Color = "Silver" oRange.Borders(c.xlEdgeBottom).Weight = c.xlThick oRange.HorizontalAlignment = c.xlHAlignCenter oOrdersSheet.Range("A:N").ColumnWidth = 20 'Query data Set oDBConn = Server.CreateObject("ADODB.Connection") OpenJet oDBConn, "eCampaigns", "" Set rJournal = oDBConn.Execute(Session("JSearchSQL")) rowForData = 2 If NOT rJournal.EOF Then rJournal.MoveFirst Do While NOT rJournal.EOF Set oRange = oOrdersSheet.Range("A" & rowForData & ":N" & rowForData) oRange.value = Array(properValueInExcel(rJournal("JournalTitle")),properValueInExcel(rJournal("JournalAuthors")),properValueInExcel(rJournal("JournalName")),properValueInExcel(rJournal("JournalYear")),properValueInExcel(rJournal("Journallanguage")),properValueInExcel(rJournal("JournalURL")),properValueInExcel(rJournal("JournalPubMedURL")),properValueInExcel(rJournal("JournalCASURL")),properValueInExcel(rJournal("JournalAbstractURL")),properValueInExcel(rJournal("JournalPDFURL")),properValueInExcel(rJournal("JournalVolume")),properValueInExcel(rJournal("JournalNumber")),properValueInExcel(rJournal("JournalAbstractText")),properValueInExcel(rJournal("JournalPages"))) rowForData = rowForData + 1 rJournal.MoveNext Loop End If '''''''''''''''''''' Future reference begin ''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Function GetOrderInfo() ' ReDim aOrderInfo(NumOrders,5) ' Dim aPrice, aDisc ' aPrice = Array(10.25, 9.5, 2.34, 6.57, 9.87, 4.55, 6, 13.05, 3.3, 5.5) ' aDisc = Array(0, 0.1, 0.15, 0.2) ' For r = 0 To NumOrders-1 ' aOrderInfo(r, 0) = "'" & String(7-Len(CStr(r+1)), "0") & r+1 'Col 1 is Order Number ' aOrderInfo(r, 1) = Int(Rnd() * NumProds) + 1 'Col 2 is Product ID ' aOrderInfo(r, 2) = Int(Rnd() * 20) + 1 'Col 3 is Quantity ' aOrderInfo(r, 3) = aPrice(aOrderInfo(r, 1)-1) 'Col 4 is Price ' aOrderInfo(r, 4) = aDisc(Int(Rnd() * 4)) 'Col 5 is Discount ' Next ' GetOrderInfo = aOrderInfo 'End Function ' 'Function GetProductIDs() ' ReDim aPIDs(NumProds, 1) ' For r = 0 To NumProds-1 ' aPIDs(r, 0) = r+1 ' Next ' GetProductIDs = aPIDs 'End Function ' ' 'Apply formatting to the columns ' oOrdersSheet.Range("A:A").ColumnWidth = 20 ' oOrdersSheet.Range("B:E").ColumnWidth = 15 ' oOrdersSheet.Range("F:F").ColumnWidth = 20 ' oOrdersSheet.Range("A2:E" & NumOrders + 1).HorizontalAlignment = c.xlHAlignCenter ' oOrdersSheet.Range("D2:D" & NumOrders + 1).NumberFormat = "0.00" ' oOrdersSheet.Range("E2:E" & NumOrders + 1).NumberFormat = "0 % " ' oOrdersSheet.Range("F2:F" & NumOrders + 1).NumberFormat = "$ 0.00" '"_($* #,##0.00_)" ' ' 'Obtain the order information for the first five columns in the Orders worksheet ' 'and populate the worksheet with that data starting at row 2 ' Dim aOrderData ' aOrderData = GetOrderInfo ' oOrdersSheet.Range("A2:E" & NumOrders + 1).Value = aOrderData ' ' 'Add a formula to calculate the order total for each row and format the column ' oOrdersSheet.Range("F2:F" & NumOrders + 1).Formula = "=C2*D2*(1-E2)" ' oOrdersSheet.Range("F2:F" & NumOrders + 1).NumberFormat = "_( $* #,##0.00 _)" ' ' 'Apply a border to the used rows ' oOrdersSheet.UsedRange.Borders(c.xlInsideHorizontal).Weight = c.xlThin ' oOrdersSheet.UsedRange.BorderAround , c.xlThin, 15 ' ' 'Turn on AutoFilter and display an initial criteria where ' 'the Product ID (column 2) is equal to 5 ' oOrdersSheet.UsedRange.AutoFilter ' oOrdersSheet.AutoFilter.Filters(2).Criteria.FilterFunction = c.ssFilterFunctionInclude ' oOrdersSheet.AutoFilter.Filters(2).Criteria.Add "5" ' oOrdersSheet.AutoFilter.Apply ' ' 'Add a Subtotal at the end of the usedrange ' oOrdersSheet.Range("F" & NumOrders + 3).Formula = "=SUBTOTAL(9, F2:F" & NumOrders + 1 & ")" ' ' 'Apply window settings for the Orders worksheet ' oOrdersSheet.Activate 'Makes the Orders sheet active ' oSS.Windows(1).ViewableRange = oOrdersSheet.UsedRange.Address ' oSS.Windows(1).DisplayRowHeadings = False ' oSS.Windows(1).DisplayColumnHeadings = False ' oSS.Windows(1).FreezePanes = True ' oSS.Windows(1).DisplayGridlines = False ' ' '=== Setup for final presentation ================================================== ' ' oSS.DisplayToolbar = False ' oSS.AutoFit = True '''''''''''''''''''' Future reference begin ''''''''''''''''''''''''''''''''''''''''''''''''''''''' oOrdersSheet.Activate Response.Write oSS.XMLData End Sub Function properValueInExcel(tmpValue) valueToReturn = "" If tmpValue <> "" Then valueToReturn = "'" & tmpValue End If properValueInExcel = valueToReturn End Function 'properValueInExcel() %>