<%option explicit%>
<%
ShopCheckAdmin "shopa_editdisplay.asp"
Dim RSTable
Dim ExportFileName
Dim ExportLocation
Dim ExportIdField
Dim ExportList
Dim ExportTable
Dim ExportDatabase
Dim ExcludeIdField
dim IdField
Dim quote
Dim dbc
Dim fso
Dim FileOpen
Dim Myfile
Dim RecordCount
Dim FieldCount
Dim AllRecords
dim exportdelimiter
'**************************************************************************
' VP-ASP 6.50
' Session Variables are used
' Session (table") = table to open
' Session ("db")= database
' Session ("ExportType") = all or selected
' Session ("Exportlist") list of records
' Session ("ExportFileName") = filename
' Session ("ExportLocation")= location of filename
'**************************************************************************
dim i,Displayfieldcount,Displayfields
Displayfieldcount=GetSess("Displayfieldcount")
Displayfields=GetSess("Displayfields")
dim rc
GetSessionVariables ' see what we must do
EditOpenDatabase dbc, ExportDatabase, ExportTable ' open database
rc=0
If ExportFilename<>"" then
AdminPageHeader
GenerateDisplayHeader "Export"
GenerateDisplayBodyHeader
OpenRealFile rc
end if
If rc=0 then
If AllRecords<>"" then
ExportAllRecords
else
ExportSelectedRecords
end if
end if
ExportTrailer
GenerateDisplayBodyFooter
AdminPageTrailer
ShopCloseDatabase dbc
'
Sub GetSessionVariables
ExportFileName=GetSess("ExportFilename")
ExportIdField=ucase(Getsess("ExportIdField"))
ExportList=GetSess("ExportList")
ExportTable=GetSess("Table")
ExportDatabase=GetSess("db")
ExportLocation=GetSess("ExportLocation")
AllRecords=GetSess("AllRecords")
Sql=GetSess("SqlQuery") ' get sql used
Fileopen=""
RecordCount=0
IDField=GetSess("Idfield")
ExcludeIdField="Yes"
Quote= chr(34)
exportdelimiter=Getsess("exportdelimiter")
'VP-ASP 6.50.1 - allow tab delimiter
if ucase(exportdelimiter) = "TAB" then exportdelimiter = vbtab
if exportdelimiter="" then
exportdelimiter=","
end if
end Sub
'************************************************************
' put out each field name being exported
'************************************************************
Sub ExportHeader
Dim msg
dim fldName
dim foundit
Fieldcount=0
if ucase(Getsess("Headerrequired"))="NO" then exit sub
For each fldName in rsTable.Fields
If displayfieldcount=0 then
foundit=true
else
foundit=false
For i = 0 to Displayfieldcount-1
if lcase(fldName.Name)=lcase(Displayfields(i)) then
foundit=true
exit for
end if
Next
end if
if FieldCount=0 and ExportIdField="NO" then
else
if foundit then
if msg="" then
msg= msg & quote & fldName.Name & quote
else
msg=msg & exportdelimiter & quote & fldName.Name & quote
end if
end if
end if
Fieldcount=Fieldcount+1
next
WriteLine msg
end sub
'
'
Sub WriteLine (msg)
If ExportFilename<>"" then
MyFile.writeline msg
else
Response.write msg & "
"
end if
RecordCount=RecordCount+1
end sub
'
Sub OpenRealFile (rc)
on error resume next
dim filename, drive, lastchar
dim whichfile
filename = ExportFilename
Drive=instr(filename,":")
if drive=0 then
If Exportlocation <>"" then
lastchar=right(exportlocation,1)
if lastchar="/" or lastchar="\" then
filename = ExportLocation & Exportfilename
else
filename = ExportLocation & "/" & Exportfilename
' filename = ExportLocation & "\" & Exportfilename
end if
else
filename = ExportFilename
end if
whichfile=server.mappath(filename)
else
whichfile=filename
end if
response.write "" & getlang("LangExport01") & "" & whichfile & "
"
response.write "" & getlang("langexportclick") & "
"
response.write "" & filename & "
"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Myfile = fso.OpenTextFile(whichfile, 2, True)
if err.number> 0 then
response.write "" & getlang("LangExportOpen") & "
" & err.description & ""
rc=4
else
rc =0
end if
end sub
'******************************************
Sub ExportAllRecords
SQL=GetSess("Sqlquery")
Set rsTable = Server.CreateObject("ADODB.Recordset")
rsTable.Open SQL, dbc, adOpenForwardOnly,adLockReadOnly
ExportHeader ' write field names
While Not rsTable.EOF
FormatRecord
rsTable.MoveNext
Wend
end sub
'
'******************************************************************
' take each record and put fields into one line'
'*****************************************************************
Sub FormatRecord
dim whatever
dim fieldvalue
Dim Msg
Dim foundit
Fieldcount=0
msg=""
for each whatever in rsTable.fields
fieldvalue=whatever.value
if isnull(fieldvalue) then
Fieldvalue=""
end if
If displayfieldcount=0 then
foundit=true
else
foundit=false
For i = 0 to Displayfieldcount-1
if lcase(whatever.name)=lcase(Displayfields(i)) then
foundit=true
exit for
end if
Next
end if
if Fieldcount=0 and ExportIdField="NO" then
else
if foundit then
If msg<>"" then
fieldvalue=replace(fieldvalue, chr(13), "")
fieldvalue=replace(fieldvalue, chr(10), "")
msg=msg & exportdelimiter & quote & fieldvalue & quote
else
msg = quote & fieldvalue & quote
end if
end if
end if
fieldcount=Fieldcount+1
next
WriteLine msg
end sub
Sub ExportRecord (recordnum)
WriteLine "One record " & recordnum
end sub
'
Sub ExportTrailer
Response.write "
" & getlang("LangExportRecords") & recordcount
response.write "
Back to Export Setup"
If Fileopen<>"" then
Myfile.close
Set fso=nothing
end if
end sub
Sub ExportSelectedRecords
Dim array
Dim I
dim item
Dim dbtable
dbtable=GetSess("Table")
sql="select * from " & lcase(dbtable)
'debugwrite sql
Set rsTable = Server.CreateObject("ADODB.Recordset")
rsTable.Open SQL, dbc, adOpenForwardOnly,adLockReadOnly
ExportHeader ' write field names
rsTable.close
set rstable=nothing
'debugwrite "ExportList=" & ExportList
array = Split(ExportList, ",", -1, 1)
for i = 0 to ubound(array)
item=Array(i)
SQL="SELECT * FROM " & lcase(dbtable) & " where " & idfield &"=" & item
set rstable=dbc.execute(sql)
FormatRecord
rsTable.close
set rstable=nothing
next
end sub
%>