eldarray, fieldname, fieldvalue, updateflag
if OnSubscribe = "" then exit sub
updateflag = false
fieldarray = split(OnSubscribe,",")
for each field in fieldarray
field = trim(field)
if instr(field,"=") > 0 then
fieldname = trim(left(field, instr(field,"=")-1))
fieldvalue = trim(mid(field, instr(field,"=")+1))
if instr(fieldvalue,"(") > 0 and instr(fieldvalue,")") > 0 then 'looks like a script
fieldvalue = eval(fieldvalue)
elseif strComp(fieldvalue,"true",1) = 0 or strComp(fieldvalue,"yes",1) = 0 or strComp(fieldvalue,"on",1) = 0 then
fieldvalue = true
elseif strComp(fieldvalue,"false",1) = 0 or strComp(fieldvalue,"no",1) = 0 or strComp(fieldvalue,"off",1) = 0 then
fieldvalue = false
elseif fieldvalue = "" then
fieldvalue = Null
end if
oRS(fieldname).value = fieldvalue
updateflag = true
end if
next
if updateflag then oRS.update
End sub
Function GetDatabase()
'retrieves the database and its configuration from the configuration file
Dim Domain, Admin, admindatabase, mailing, database, DomainArray, Company
Dim MailingFolder, Config, ConfigFile, ErrorMessage, fso, fil
if not data.exists("mailing") then
Getdatabase = "Error"
exit function
end if
mailing = data("mailing")
If mailing = "" then
GetDatabase = "Error"
exit function
else
set fso = server.createobject("Scripting.FileSystemObject")
if instr(mailing,"@") = 0 then
refferer = Request.ServerVariables("HTTP_REFERER")
else
refferer = mid(mailing,instr(mailing,"@")+1)
mailing = left(mailing,instr(mailing,"@")-1)
data("mailing") = mailing
end if
refferer = replace(refferer, "http://", "",1,-1,1)
refferer = trim(replace(refferer, "www.", "",1,-1,1))
refArray = split(refferer, "/")
refferer = refArray(0)
DomainArray = split(refferer, ".")
if len(DomainArray(1)) > 3 then
Company = DomainArray(0) & "." & DomainArray(1)
else
Company = DomainArray(0)
end if
mailingFolder = "e:\mailings\" & company & "\" & mailing & "\"
if fso.folderExists(mailingFolder) then
config = ""
configFile = "users.config"
else
getdatabase = "Error"
exit function
end if
'Database can be in any one of three positions:
'First, a domain subfolder in e:\mailings and then a sub-folder related to the particular mailing
'Second, just in the domain subfolder in e:\mailings
'Third, in a domain subfolder of Imail under lists for that domain
If not fso.FolderExists(MailingFolder & database) then 'check for e.g. e:\mailings\clientdomain\news folder
If not fso.FolderExists(MailingFolder) then 'check for e.g. e:\mailings\clientdomain folder in folder above
MailingFolder = "e:\imail\" & replace(Domain,".","_") & "\lists\" 'look in Imail?
If not fso.FolderExists(MailingFolder & database) then
ErrorMessage = "Can't find mailing folder in e:\imail or e:\mailings."
Else
MailingFolder = MailingFolder & database
Config = readFile(MailingFolder & "\" & ConfigFile)
End if
Else
Config = readFile(MailingFolder & ConfigFile)
End if
Else
MailingFolder = MailingFolder & database
Config = readFile(MailingFolder & "\" & ConfigFile)
End if
If Config = "" then
ErrorMessage = "Can't find configuration file " & ConfigFile & " for " & database
End if
set fso = nothing
If ErrorMessage = "" then
ListFormat = "" : ListSeparator = ""
Execute Config 'load all the values from the config file
data("EmailField") = EmailField
data("NameField") = NameField
data("KeyField") = KeyField
data("listField") = ListField
data("Table") = DatabaseTable
If ListFormat <> "" then data("ListFormat") = ListFormat
If ListSeparator <> "" then data("ListSeparator") = ListSeparator
if instr(DatabaseName,":") > 0 then 'if database is defined with a full path
database = DatabaseName
elseif instr(1,DatabaseName,".mdb",1) > 0 then
database = mailingfolder & DatabaseName
else
database = DatabaseName 'SQL
end if
database = replace(database,"\\","\") 'remove any \\ that may have crept in
GetDatabase = database
Else
GetDatabase = "Error"
End if
End if
End function
'******************************************************
Sub AddToErrorMessage(Txt)
ErrorMessage = ErrorMessage & Txt & "
"
End sub
' Open Access Database
'******************************************************
' Open Database
Sub OpenDatabase(connection, database)
dim strconn, ServerIP
ServerIP = GetSQLServerIP
if lcase(right(database,4)) = ".mdf" or (instr(1,database, ".mdf") = 0 and instr(1,database, ".mdb") = 0) then 'database is SQL
if instr(1,database, ".mdf") = 0 and instr(1,database, ".mdb") = 0 then
database = database
else
database = mid(database,instrRev(database,"\",-1,1)+1)
database = left(database,len(database)-4)
end if
strconn = "Provider=sqloledb;" & _
"Network Library=DBMSSOCN;" & _
"Data Source=62.197.43.10,1433;" & _
"Initial Catalog=" & database & ";" & _
"User Id=iusr;" & _
"Password=" & "kjha#~[sdjga9u45jh43uo"
else
If instr(database,".") = 0 then database = database & ".mdb"
database = replace(database, "/", "\")
database = replace(database, "\\\", "e:\")
database = replace(database, "\\", xDatabaseRoot)
database = replace(database, "\\", "\")
If ScriptType = "ASP" and instr(Database,":") = 0 then 'must be relative address
Database = server.mappath(Database)
End if
strconn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & database & ";"
end if
Set connection = Server.CreateObject("ADODB.Connection")
connection.open strConn
End Sub
'************ Open a recordset for reading ******************
Sub OpenRecordSet (connection, sql, rs, action)
if connection = "" then
exit sub
end if
Set rs = Server.CreateObject("ADODB.RecordSet")
rs.cursorlocation=aduseclient
rs.cachesize=5
if lcase(action) = "write" then
rs.Open sql, connection, adOpenKeyset, adLockOptimistic, adCmdText
else
rs.Open sql,connection,adOpenForwardOnly,adLockReadOnly, adCmdText
end if
if not rs.eof then
rs.movefirst
end if
end sub
'*************** Close database ************
Sub CloseDatabase (connection)
If isObject(connection) then
connection.close
set connection=nothing
End if
End sub
Function ReadFile(Filename)
Dim fso, fil
If Filename = "" then
Exit function
End if
set fso = server.CreateObject("Scripting.FileSystemObject") 'open file system
if instr(Filename,":") = 0 then
Filename = server.mappath(Filename)
end if
If not fso.FileExists(Filename) then
set fso = nothing
exit function
End if
set fil = fso.OpenTextFile(Filename,1)
ReadFile = fil.ReadAll
set fil = nothing
set fso = nothing
End function
Function CountFile(Filename)
Dim fso, fil, line
If Filename = "" then
Exit function
End if
set fso = server.CreateObject("Scripting.FileSystemObject") 'open file system
if instr(Filename,":") = 0 then
Filename = server.mappath(Filename)
end if
If not fso.FileExists(Filename) then
set fso = nothing
exit function
End if
set fil = fso.OpenTextFile(Filename,1)
Do until fil.AtEndOfStream
Line = fil.ReadLine
CountFile = CountFile + 1
Loop
set fil = nothing
set fso = nothing
End function
Function WriteFile(Filename,Txt)
Dim fso, fil
WriteFile = false
If Filename = "" or Txt = "" then
Exit function
End if
set fso = server.CreateObject("Scripting.FileSystemObject") 'open file system
if instr(Filename,":") = 0 then
Filename = server.mappath(Filename)
end if
set fil = fso.CreateTextFile(Filename,True)
fil.Write Txt
WriteFile = True
set fil = nothing
set fso = nothing
End function
Sub View(ByVal action, ByVal Txt)
Dim Temp
if strComp(Txt,"end",1) = 0 or strComp(Txt,"quit",1) = 0 then 'got the arguments the wrong way around!
Temp = action
action = Txt
Txt = Temp
end if
If ScriptType = "ASP" then
If request.servervariables("Remote_addr") = "217.64.124.161" or left(request.servervariables("Remote_addr"),4) = "127." then
response.write Time & " " & Txt & "
"
if strComp(action,"end",1) = 0 or strComp(action,"quit",1) = 0 then response.end
End if
Else
msgbox Time & vbCrlf & Txt
if strComp(action,"end",1) = 0 or strComp(action,"quit",1) = 0 then wsh.quit
End if
End sub
'set constants for database reading
'---- CursorTypeEnum Values ----
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
'---- CursorOptionEnum Values ----
Const adHoldRecords = &H00000100
Const adMovePrevious = &H00000200
Const adAddNew = &H01000400
Const adDelete = &H01000800
Const adUpdate = &H01008000
'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
'---- CursorLocationEnum Values ----
Const adUseServer = 2
Const adUseClient = 3
'---- CommandTypeEnum Values ----
Const adCmdUnknown = &H0008
Const adCmdText = &H0001
Const adCmdTable = &H0002
Const adCmdStoredProc = &H0004
'---- DataTypeEnum Values ----
Const adEmpty = 0
Const adTinyInt = 16
Const adSmallInt = 2
Const adInteger = 3
Const adBigInt = 20
Const adUnsignedTinyInt = 17
Const adUnsignedSmallInt = 18
Const adUnsignedInt = 19
Const adUnsignedBigInt = 21
Const adSingle = 4
Const adDouble = 5
Const adCurrency = 6
Const adDecimal = 14
Const adNumeric = 131
Const adBoolean = 11
Const adError = 10
Const adUserDefined = 132
Const adVariant = 12
Const adIDispatch = 9
Const adIUnknown = 13
Const adGUID = 72
Const adDate = 7
Const adDBDate = 133
Const adDBTime = 134
Const adDBTimeStamp = 135
Const adBSTR = 8
Const adChar = 129
Const adVarChar = 200
Const adLongVarChar = 201
Const adWChar = 130
Const adVarWChar = 202
Const adLongVarWChar = 203
Const adBinary = 128
Const adVarBinary = 204
Const adLongVarBinary = 205
%>