<%Option Explicit%>
<%
shopcheckadmin "shopa_import.asp"
'******************************************************************
' This program reads the export of database
' Can be called via
' upload=yes then filename is in session(uploadfile)
' can be called via admin It then prompts for file
'
' Input
' data set name can be anything
' data must be comma delimited
' First record must be header with field names
' VP-ASP 6.50 July 3, 2005
' Matches products or other tables
'************************************************************************
dim dbc
dim currentcatalogid
Dim filename
Dim errorcount
Dim infilenum
Dim rc
dim f
Dim CloseCount
Dim delimiter
Dim record
Dim Headerfieldnames(200)
Dim Headerfieldcount
Dim dbIndex(200)
Dim dbFields(200)
Dim dbtypes(200)
Dim dbtables(200)
Dim dbsizes(200)
Dim dbFieldCount
Dim dbfield ' field being processed
Dim values(200)
Dim valuecount
Dim faddnew
Dim ssql
Dim rs
Dim db
Dim efilenum
Dim fsobj, Recordobj
Dim errorfilename
Dim interviewmsg
Dim subdirs
Dim xfilename
Dim batch
Dim part
Dim cntNew
Dim cntUpdate
dim upload, sACtion
Dim options(3)
dim idfield
dim optioncount, resultsflag, temp
options(0)=trim( getlang("LangCommonYes"))
options(1)=trim( getlang("LangCommonNo"))
Dim Yes
Dim RecordCount
dim Directory, usertables, tablecount
Yes=trim( getlang("LangCommonYes"))
optioncount=2
Serror=""
dim matchfield, importdelimiter, tablename
dim doupdate, mysqlflag
'
'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set
if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then
mysqlflag="Yes"
end if
'matchfield=getconfig("ximportmatchfield")
if matchfield="" then
matchfield="ccode"
end if
importdelimiter=","
tablename="products"
AdminPageHeader
upload=request("upload")
if upload<>"" then
Filename=GetSess("Importfilename")
Resultsflag= getlang("LangCommonYes")
else
Filename=request("filename")
Resultsflag=Request("ResultsFlag")
end if
If filename="" Then
Filename=GetSess("Importfilename")
end if
sAction=Request("Action")
If sAction = "" and upload="" Then
DisplayForm
Else
ValidateData()
if sError = "" Then
Importdata filename
Displayform
else
DisplayForm
end if
end if
gethelp
adminPageTrailer
'*********************************************************************
' main import logic
'*********************************************************************
Sub ImportData(ifilename)
GenerateDisplayHeader "Importing - " & filename
GenerateDisplayBodyHeader
dim eofrc
Initialize ifilename, eofrc ' get file to import
If eofrc > 0 Then Exit Sub
ReadARecord RecordObj, record, eofrc
RecordCount=1
Do While eofrc=0 ' EOF is returned when no more
InItvalues
ProcessRecord ' update database wth the record
ReadARecord RecordObj, record, eofrc
RecordCount=RecordCount+1
HandleTimeout
Loop
CloseFile fsObj,RecordObj, rc
DisplaySummary ' msgbox on pilot refernces processed
shopclosedatabase dbc
GenerateDisplayBodyFooter
End Sub
Sub ProcessRecord()
'*****************************************************************************
' we have read in one record
' get the individual fields in array values
' locate the associated persion record
' then locate or add the result records
'******************************************************************************
dim index, catalogid
ParseValues record
index=LocateField(matchfield)
catalogid=values(index)
if catalogid="" then
Writeerror " " & getlang("LangImportMatchfield") & " " & getlang("langcustrequired") & " " & getlang("LangTemplateRecord") & "=" & recordcount
shopwriteerror " " & record
exit sub
end if
GetExistingRecord catalogid ' get Result table or create it
UpdateRecord
If serror<>"" then
WriteError serror
serror=""
end if
End Sub
Sub Initialize(ifilename, rc)
'***********************************************************************
' Read the file namep firsat record
' Get TGhe first record field names
' Get all the database field names dbfieldcount, dbfields
' Locate which input name match which database name dbindex holds values
'***********************************************************************
Server.ScriptTimeout = 3600
f=0
closecount=0
'VP-ASP 6.08
Select Case ucase(tablename)
Case "CUSTOMERS"
OpenCustomerDb dbc
Case "PRODUCTS"
ShopopendatabaseP dbc
Case "ORDERS"
OpenOrderDb dbc
Case "OITEMS"
OpenOrderDb dbc
Case "MYCOMPANY"
OpenOrderDb dbc
Case "AFFILIATES"
OpenAffiliateDB dbc
Case "SEARCHRESULTS"
ShopOpenOtherDB dbc, getconfig("xSearchDb")
Case "PROJECTS"
ShopOpenOtherDB dbc, getconfig("xprojectDb")
Case "CATEGORIES"
ShopopendatabaseP dbc
Case "PRODCATEGORIES"
ShopopendatabaseP dbc
Case "PRODFEATURES"
ShopopendatabaseP dbc
Case "TRANSLATEPRODUCTS"
ShopopendatabaseP dbc
Case "TRANSLATECATEGORIES"
ShopopendatabaseP dbc
Case "TRANSLATEPROD"
ShopopendatabaseP dbc
Case Else
Shopopendatabase dbc
End Select
OpenInputFile ifilename, fsObj, RecordObj, rc
If rc > 0 Then
Serror=serror & getlang("LangReadFail") & " " & ifilename & " "
Exit Sub
End If
cntNew = 0
cntUpdate = 0
GetFieldHeaders ' get field names on record
GetdbFields ' get field names in the database
GetdbtoHeaders 'locate which field in record matches database
End Sub
Sub DisplayForm()
AddImportform
GenerateDisplayHeader getlang("LangImport")
GenerateDisplayBodyHeader
Displayerrors
setupusertables
%><%
generatedisplaybodyfooter
'AddImportform
end sub
Sub CreateRow (caption, fieldname, fieldvalue)
Dim aster
Response.write tablerow & tablecolumn & Caption & tablecolumnend & tablecolumn
%>
<%
Response.write Tablecolumnend & tablerowend
end sub
Sub DisplayErrors
if sError<> "" then
shopwriteerror SError
Serror=""
end if
end Sub
Sub ValidateData
If filename="" then
Serror=serror & getlang("langmenufilename") & " " & getlang("Langcustrequired") & " "
end if
tablename=request("tablename")
if tablename="" then
Serror=serror & getlang("LangEditTableName") & " " & getlang("Langcustrequired") & " "
end if
matchfield=request("matchfield")
if tablename="" then
Serror=serror & getlang("LangImportmatchfield") & " " & getlang("Langcustrequired") & " "
end if
importdelimiter=request("importdelimiter")
if importdelimiter="" then
Serror=serror & getlang("LangDelimiter") & " " & getlang("Langcustrequired") & " "
end if
end sub
Sub InitValues
dim i, limit
limit=ubound(values)
for i = 0 to limit
values(i)=""
next
end sub
'*********************************************************
' get record field names
'********************************************************
Sub GetFieldHeaders()
dim i
delimiter=importdelimiter
ReadARecord RecordObj, record, rc
If rc>0 Then
WriteError getlang("LangMenuFileName") & " " & getlang("Langcustrequired")
End If
'VP-ASP 6.50 - allow TAB delimiters
if (UCASE(delimiter)="TAB") then
ParseRecord record, Headerfieldnames, Headerfieldcount, vbtab
else
ParseRecord record, Headerfieldnames, Headerfieldcount, delimiter
end if
'debugwrite record
'debugwrite "number of headers=" & headerfieldcount
for i = 0 to headerfieldcount
headerfieldnames(i)=replace(headerfieldnames(i),"""","")
headerfieldnames(i)=ucase(headerfieldnames(i))
next
End Sub
'
Sub GetdbFields()
'***************************************************************************
' Get the field names for each of the five tables result1..8
'****************************************************************************
Dim i, t, db
Dim td
Dim fname
Sql="select * from " & tablename
set td=dbc.execute(sql)
Dim fieldcount
Dim pos
dbFieldCount = 0
fieldcount = td.Fields.count
For i = 0 To fieldcount - 1
fname = td.Fields(i).name
dbFields(dbFieldCount) = ucase(fname)
' debugwrite fname
dbtypes(dbFieldCount) = td.Fields(i).Type
dbsizes(dbFieldCount) = td(i).definedsize
dbFieldCount = dbFieldCount + 1
Next
td.close
Set td = Nothing
End Sub
Sub GetExistingRecord (catalogid)
'************************************************************************
' if record alread exists in results, nothing to do
' others add a record to each result table so that we can do updates
' and not adds
'*************************************************************************
If Mysqlflag="Yes" then
Mysqlgetexistingrecord (catalogid)
exit sub
end if
dim lngcatid, doupdate
If ucase(matchfield)<>ucase(dbfields(0)) Then
sql = "select * from " & tablename & " where " & matchfield &"='" & catalogid & "'"
else
sql = "select * from " & tablename & " where " & matchfield &"=" & catalogid
end if
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.open SQL, dbc, adOpenKeyset, adLockOptimistic, adcmdText
if not ObjRS.eof then
DoUpdate="True"
cntupdate=cntupdate+1
currentcatalogid=objrs(0)
If ResultsFlag=Yes then
Response.write getlang("LangProductUpdated") & " " & catalogid & " "
end if
else
objRs.close
set objRS=nothing
end if
If Doupdate="" then
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.open tablename, dbc, adOpenKeyset, adLockOptimistic, adCmdTable
objRS.AddNew
' objrs.update
cntnew=cntNew+1
'currentcatalogid=objrs(0)
If ResultsFlag=Yes then
response.write getlang("LangProductAdded") & " current catlogid=" & currentcatalogid & " "
end if
end if
'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories
if lcase(tablename) = "categories" then
if objRS("highercategoryid") = currentcatalogid then
serror=serror & "Higher Category ID is the same as the Category ID for Record #" & currentcatalogid & ". Please update this record manually. "
end if
end if
End Sub
'
Sub UpdateRecord
If mysqlflag="Yes" then
Mysqlupdaterecord
exit sub
end if
' Write update for each field in one table
Dim firstfield
Dim fieldlimit
Dim setcount
Dim i
Dim value
Dim newvalue
dim categoryid, subcategoryid, catalogid
categoryid=""
catalogid=""
subcategoryid=""
firstfield = False
For i = 0 To dbFieldCount-1
dbfield = dbFields(i) ' for debugging
If dbIndex(i) <> -1 Then
If i >0 then
value = values(dbIndex(i)) ' which value matches this db field
ConvertValue dbfield, value, newvalue, dbtypes(i),dbsizes(i) ' convert this field
if doupdate="" then
If newvalue<>"" then
' debugwrite dbfield & "=" & newvalue
objrs(dbfield)=newvalue
end if
else
'debugwrite dbfield & "=" & newvalue
objrs(dbfield)=newvalue
end if
if dbfield="CCATEGORY" then
categoryid=values(dbindex(i))
end if
if dbfield="SUBCATEGORYID" then
subcategoryid=values(dbindex(i))
end if
end if
end if
next
objrs.update
currentcatalogid=objrs(0)
UpdateCategoryTables currentcatalogid, categoryid, subcategoryid
End Sub
Sub ConvertValue(dbfield, value, newvalue, dbtype, dbsize)
Dim fixvalue
newvalue=value
'Debugwrite value & " type=" & dbtype & " size=" & dbsize
Select Case dbtype
Case "11"
' boolean value
if value="" then
value=0
exit sub
end if
If ucase(value) = "TRUE" Then
newvalue =1
Else
if ucase(value) = "FALSE" then
newvalue = 0
End If
end if
Case "133","135"
if value="" then exit sub
newvalue = datenormalize(value)
Case "3" ' Number
exit sub
Case "202" ' Text
if len(value)>dbsize then
newvalue=left(value,dbsize)
serror=serror & dbfield & " truncated. " & value & "(" & len(value) & ") maxsize=" & dbsize & " record=" & recordcount & " "
end if
Case Else
' other value
newvalue = value
End Select
'newvalue=replace(newvalue,"'","''")
'newvalue="'" & newvalue & "'"
End Sub
Sub GetdbtoHeaders()
Dim i
For i = 0 To dbFieldCount - 1
dbIndex(i) = LocateField(dbFields(i))
Next
End Sub
Sub WriteError(msg)
Dim outmsg
errorcount = errorcount + 1
shopwriteerror msg
End Sub
Function LocateField(ifieldname)
Dim t , fieldname
LocateField = -1
fieldname=ucase(Ifieldname)
For t = 0 To Headerfieldcount - 1
If Headerfieldnames(t) = fieldname Then
LocateField = t
Exit For
End If
Next
If LocateField = -1 Then
' bypass generated field
' WriteError "Unable to locate field " & fieldname & " in exported record"
End If
End Function
Function LocatedbField(fieldname)
Dim t
LocatedbField = -1
For t = 0 To dbFieldCount
If dbFields(t) = fieldname Then
LocatedbField = t
Exit For
End If
Next
End Function
Sub DisplaySummary()
response.write " "
if errorcount>0 then
response.write "Errors = " & errorcount & " "
end if
response.write getlang("LangProductadded") & " = " & cntNew & " "
response.write getlang("LangProductupdated") & " = " & cntUpdate
End Sub
Sub ParseValues (record)
dim delimiter, fieldvalue, firstchar, lastchar
dim tempvals(1000), tempcount, index, i
for i=0 to ubound(tempvals)
tempvals(i)=""
next
delimiter=importdelimiter
valuecount=0
'VP-ASP 6.50 - allow TAB delimiter
if (UCASE(delimiter)="TAB") then
ParseRecord record, tempvals, tempcount, vbtab
else
ParseRecord record, tempvals, tempcount, delimiter
end if
Index=0
for i = 0 to tempcount
fieldvalue=tempvals(index)
firstchar=left(fieldvalue,1)
if FirstChar="""" then
GetQuotedField fieldvalue, index, tempvals
end if
' debugwrite "i=" & valuecount & "value=" & fieldvalue
values(valueCount)=fieldvalue
if getconfig("xdebug")="Yes" then
if fieldvalue="" Then
debugwrite "NULL"
else
debugwrite values(valuecount)
end if
end if
valuecount=valuecount+1
index=index+1
next
end sub
Sub GetQuotedField (Fieldvalue, index, tempvals)
dim endchar
dim length
length=len(fieldvalue)
endchar=right(fieldvalue,1)
'debugwrite fieldvalue
If endchar="""" then
fieldvalue=replace(fieldvalue,"""","")
exit sub
end if
Do while endchar<>""""
index=index+1
If Index> length then
exit do
end if
fieldvalue=fieldvalue & "," & tempvals(index)
endchar=right(fieldvalue,1)
'debugwrite fieldvalue
loop
fieldvalue=replace(fieldvalue,"""","")
end sub
'
Sub HandleTimeout
closecount=closecount+1
if closecount>= 100 then
shopclosedatabase dbc
shopopendatabaseP dbc
closecount=0
response.flush
end if
If ResultsFlag="Yes" then exit sub
f=f+1
IF f>200 then
f=0
Response.Write(" ")
end if
if ((f mod 5) = 0) then
Response.Write(".")
Response.Flush
end if
end sub
Sub OpenInputFile (filename, fsObj, RecordObj, rc)
'on error resume next
Dim whichfile, drive
Drive=instr(filename,":")
if drive=0 then
whichfile=server.mappath(filename)
else
whichfile=filename
end if
set fsObj = Server.CreateObject("Scripting.FileSystemObject")
set RecordObj= fsObj.OpenTextFile(whichfile, 1, False)
If err.number > 0 then
rc=4
fsObj.close
set fsObj=nothing
Serror=Serror & getlang("LangReadfail") & whichfile & " " & err.description & " "
else
rc=0
' debugwrite whichfile & " opened ok "
end if
End sub
'
' close a file
Sub CloseFile (fsObj, RecordObj, rc)
set RecordObj = nothing
set fsObj = nothing
rc=0
end sub
Sub ReadARecord (RecordObj, record, rc)
if RecordObj.AtEndofStream then
rc=4
exit sub
end if
record = RecordObj.readline
rc=0
End Sub
Sub MYsqlGetExistingRecord (catalogid)
'************************************************************************
' if record alread exists in results, nothing to do
' others add a record to each result table so that we can do updates
' and not adds
'*************************************************************************
dim lngcatid, sqlo,strsql,rstemp
idfield=dbfields(0)
doupdate=""
If ucase(matchfield)<>ucase(dbfields(0)) Then
sql = "select * from " & tablename & " where " & matchfield &"='" & catalogid & "'"
else
sql = "select * from " & tablename & " where " & matchfield &"=" & catalogid
end if
Set objRS = dbc.execute(sql)
'debugwrite sql
if not ObjRS.eof then
DoUpdate="True"
currentcatalogid=objrs(idfield)
cntupdate=cntupdate+1
If ResultsFlag=Yes then
Response.write getlang("LangProductUpdate") & " " & catalogid & " "
end if
'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories
if lcase(tablename) = "categories" then
if clng(objRS("highercategoryid")) = clng(catalogid) then
serror=serror & "Higher Category ID has been set to Category ID for Record #" & catalogid & ". Please update this record manually. "
end if
end if
end if
objRs.close
set objRS=nothing
If Doupdate="" then
cntnew=cntNew+1
currentcatalogid=""
If ResultsFlag=Yes then
response.write getlang("LangProductAdd") & " " & catalogid & " "
end if
end if
End Sub
Sub MYSQLUpdateRecord
' Write update for each field in one table
Dim firstfield
Dim fieldlimit
Dim setcount
Dim i
Dim value
Dim newvalue
dim fieldname, fieldvalue, updatesql
dim xxnames,yyvalues
firstfield = False
Updatesql=""
xxnames=""
yyvalues=""
For i = 0 To dbFieldCount-1
dbfield = dbFields(i) ' for debugging
If dbIndex(i) <> -1 Then
If i >0 then
value = values(dbIndex(i)) ' which value matches this db field
'debugwrite dbfield & "type=" & dbtypes(i) & "value=" & value
If doupdate="" then
If value<>"" then
MYSQLConvertValue dbfield, value, newvalue, dbtypes(i), dbsizes(i) ' convert this field
fieldvalue=newvalue
fieldname=dbfield
MYSQLAddImportfield xxnames,yyvalues,fieldname,fieldvalue
end if
else
MYSQLConvertValue dbfield, value, newvalue, dbtypes(i),dbsizes(i) ' convert this field
fieldvalue=newvalue
fieldname=dbfield
MYSQLUpdateImportfield updatesql,fieldname,fieldvalue
end if
end if
end if
next
If doupdate="" then
updatesql="insert into " & tablename & "(" & xxnames & ") values(" & yyvalues & ")"
'debugwrite updatesql
dbc.execute(updatesql)
else
updatesql ="update " & tablename & " " & updatesql
updatesql=updatesql & " where " & idfield & "=" & currentcatalogid
'debugwrite updatesql
dbc.execute(updatesql)
end if
End Sub
Sub MysqlUpdateImportField (updatesql,fieldname, fieldvalue)
If updatesql="" then
updatesql="SET "
else
updatesql= updatesql & ","
end if
updatesql=updatesql & lcase(fieldname) & "=" & fieldvalue
end sub
Sub MysqlAddImportField (names,values,fieldname, fieldvalue)
If fieldvalue="" then exit sub
If names<>"" then
names=names & ","
values=values & ","
end if
names=names & fieldname
values=values & fieldvalue
end sub
Sub MYSQLConvertValue(dbfield,value, newvalue, dbtype,dbsize)
Dim fixvalue
newvalue=value
If value="" Then
newvalue="NULL"
exit sub
end if
'DEbugwrite "value=" & value & " ttype=" & dbtype
Select Case dbtype
Case "11"
' boolean value
if value="" then
newvalue=0
exit sub
end if
If ucase(value) = "TRUE" Then
newvalue =1
Else
if ucase(value) = "FALSE" then
newvalue = 0
End If
end if
Case "133","135"
newvalue = datenormalize(value)
Case "3" ' Number
exit sub
Case Else
newvalue=replace(newvalue,"'","''")
newvalue="'" & newvalue & "'"
End Select
End Sub
Sub UpdateCategoryTables (catalogid, categoryid, subcategoryid)
if ucase(tablename)<>"PRODUCTS" then exit sub
'debugwrite "catalogid=" & catalogid & " cat=" & categoryid & " subcat=" & subcategoryid
UpdateProdCategories catalogid, categoryid
UpdateProdSubCategories catalogid, subcategoryid
'UpdateSpecialCategories catalogid
end sub
Sub UpdateProdcategories (catalogid, categoryid)
dim sql, rs
dim found
If categoryid="" or catalogid="" then exit sub
if clng(categoryid)=0 then exit sub
sql="select * from prodcategories where intcatalogid=" & catalogid
sql=sql & " and intcategoryid=" & categoryid
'debugwrite sql
set rs=dbc.execute(sql)
if not rs.eof then
found=True
end if
rs.close
set rs=nothing
if found=false then
sql="insert into prodcategories (intcategoryid,intcatalogid) values (" & categoryid & "," & catalogid & ")"
' debugwrite sql
dbc.execute(sql)
end if
end sub
'
Sub UpdateProdSubcategories (catalogid, subcategoryid)
dim sql, rs
dim found
If subcategoryid="" then exit sub
if clng(subcategoryid)=0 then exit sub
sql="select * from prodcategories where intcatalogid=" & catalogid
sql=sql & " and intcategoryid=" & subcategoryid
set rs=dbc.execute(sql)
if not rs.eof then
found=True
end if
rs.close
set rs=nothing
if found=false then
sql="insert into prodcategories (intcategoryid,intcatalogid) values (" & subcategoryid & "," & catalogid & ")"
' debugwrite sql
dbc.execute(sql)
end if
end sub
'
Sub UpdateSpecialcategories (catalogid)
dim index
index=locatefield("category1")
if index>0 then
category1=values(index)
if category1<>"" then
if isnumeric(category1) then
UpdateProdcategories catalogid, category1
end if
end if
end if
index=locatefield("subcategory1")
if index>0 then
subcategory1=values(index)
if subcategory1<>"" then
if isnumeric(subcategory1) then
UpdateProdSubcategories catalogid, subcategory1
end if
end if
end if
end sub
sub AddImportform
directory="import"
generatedisplayheader getlang("LangImport") & " - " & getlang("langcommonupload")
generatedisplaybodyheader
%>
To import a file select below and the file will be uploaded to your server and the fields below will be automatically populated.
<%
generatedisplaybodyfooter
end sub
Sub SetupUserTables
UserTables=split(GetSess("UserTables"),",",-1,1)
tablecount=ubound(UserTables)
tablecount=tablecount+1
end sub
%>