Object in SMTPSink looses Value

[jehemo2001]

I wrote a SMTPSink to apply rules to messages. After a Sub Call, the Object objMessage, that holds the incoming Message points to Null. Enviroment: Exchange Server 2000, Windows Server 2000. Any Idea???

(Sorry for bad english, i'm german)

SmtpSink:
<SCRIPT LANGUAGE="VBScript">
Option Explicit


' Pfad und Dateiname der Log-Datei
Const LogFile = "C:\smtpsink\verteilung.log"
' errorlogging 0=no logging, 1=Fatal 2=Error 3=Warning 4=information 5=debug
Const LogLevel = 5

Dim FieldValue(11) ' 1 = from
' 2 = to
' 3 = cc
' 4 = bcc
' 5 = sender
' 6 = subject
' 7 = return path
' 8 = envelope to
' 9 = body (text)
'10 = body (html)
'11 = hasattachment

Sub ISMTPOnArrival_OnArrival(ByVal objMessage, EventStatus)
On Error Resume Next

Dim mail
Dim Fields
Dim DB, RS
Dim tempbool(9)
Dim i
Dim y
Dim objStream
Dim newval

Set Fields = objMessage.Fields
if (err.number <> 0) Then AppendLog "Set Fields=ObjMessage.Fields: " & err.Description, 2
FieldValue(1) = Fields("urn:schemas:httpmail:from").Value
FieldValue(2) = Fields("urn:schemas:httpmail:to").Value
FieldValue(3) = Fields("urn:schemas:httpmail:cc").Value
FieldValue(4) = Fields("urn:schemas:httpmail:bcc").Value
FieldValue(5) = Fields("urn:schemas:httpmail:sender").Value
FieldValue(6) = Fields("urn:schemas:httpmail:subject").Value
FieldValue(7) = Fields("urn:schemas:mailheader:return-path").Value
FieldValue(8) = Fields("urn:schemas:mailheader:envelope-to").Value
FieldValue(9) = Fields("urn:schemas:httpmail:textdescription").Val ue
FieldValue(10) = Fields("urn:schemas:httpmail:htmldescription").Val ue
FieldValue(11) = Fields("urn:schemas:httpmail:hasattachment").Value
AppendLog "NEW MAIL", 4
AppendLog " FROM:" & FieldValue(1), 4
AppendLog " TO:" & FieldValue(2), 4
AppendLog " CC:" & FieldValue(3), 4
AppendLog " BCC:" & FieldValue(4), 4
AppendLog " SENDER:" & FieldValue(5), 4
AppendLog " SUBJECT:" & FieldValue(6), 4
AppendLog " RETURN-PATH:" & FieldValue(7), 4
AppendLog " ENVELOPE-TO:" & FieldValue(8), 4
AppendLog " TEXTBODY:" & replace(left(FieldValue(9),40),vbcrlf,"<crlf>") & " ...", 5
AppendLog " TEXTBODY-Length:" & cstr(len(FieldValue(9))), 5
AppendLog " HTMLBODY:" & replace(left(FieldValue(10),40),vbcrlf,"<crlf>") & " ...", 5
AppendLog " HTMLBODY-Length:" & cstr(len(FieldValue(10))), 5
AppendLog " HASATTACHMENT:" & cstr(FieldValue(11)), 4

if (err.number <> 0) Then AppendLog err.Description, true

Set DB = CreateObject("ADODB.Connection")
DB.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data source=C:\smtpsink\Verteilung.mdb"
if (err.number <> 0) Then AppendLog err.Description, true
AppendLog " Database Connect established", 5
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM Regeln", DB, 3, 3
if (err.number <> 0) Then AppendLog err.Description, true
AppendLog " Recordset selected", 5

RS.Movefirst
while not RS.EOF
AppendLog " Regeltest: " & RS.Fields("Regelname"), 5
i=0



Set ObjStream = Nothing
Set objStream = objMessage.GetStream
if (err.number <> 0) Then AppendLog "WasDas 3:" & err.Description, true

while i<=9
tempbool(i)=0
checkbedingung cint(RS.Fields("Feld"&i)), RS.Fields("EQ"&i), RS.Fields("RegEx"&i), tempbool(i)
i=i+1
wend
tempbool(1)=tempbool(1)+tempbool(2)+tempbool(3)
tempbool(2)=tempbool(4)+tempbool(5)+tempbool(6)
tempbool(3)=tempbool(7)+tempbool(8)+tempbool(9)

Set ObjStream = Nothing
Set objStream = objMessage.GetStream
if (err.number <> 0) Then AppendLog "WasDas 4:" & err.Description, true

if (tempbool(1)=0 or tempbool(1)>3) AND (tempbool(2)=0 or tempbool(2)>3) AND (tempbool(3)=0 or tempbool(3)>3) then
AppendLog " Regelmatch found: " & RS.Fields("Regelname"), 4
i=1
AppendLog " Act1: " & RS.Fields("Act"&i), 5
AppendLog " Wert1: " & RS.Fields("Wert"&i), 5
while i<=3
if cint(RS.Fields("Act"&i)) = 1 then
AppendLog " Weiterleitung gefunden", 5
if len(RS.Fields("Wert"&i))>0 then
AppendLog " Weiterleitung an "&RS.Fields("Wert"&i), 5
set objStream = objMessage.GetStream
if (err.number <> 0) Then AppendLog "ObjStream.GetStream: " & err.Description, 2
AppendLog " GetStream successful", 5
if (len(FieldValue(4)) > 0) Then
newval = FieldValue(4) & ", " & RS.Fields("Wert"&i)
AppendLog " BCC updated: " & newval, 5
mail = replace(objStream.ReadText, FieldValue(4), newval)
if (err.number <> 0) Then AppendLog "ObjStream.ReadText: " & err.Description, 2
else
newval = vbcrlf & "BCC: " & RS.Fields("Wert"&i) & vbcrlf & vbcrlf
AppendLog " BCC created: " & RS.Fields("Wert"&i) , 5
mail = replace(objStream.ReadText, vbcrlf & vbcrlf, newval)
if (err.number <> 0) Then AppendLog "ObjStream.ReadText: " & err.Description, 2
end if
objStream.Position = 0
if (err.number <> 0) Then AppendLog "ObjStream.Position: " & err.Description, 2
objStream.WriteText(mail)
if (err.number <> 0) Then AppendLog "ObjStream.WriteText: " & err.Description, 2
objStream.SetEOS
if (err.number <> 0) Then AppendLog "ObjStream.SetEOS: " & err.Description, 2
objStream.Flush
if (err.number <> 0) Then AppendLog "ObjStream.Flush: " & err.Description, 2
objMessage.DataSource.Save ' write back to CDO-object
if (err.number <> 0) Then AppendLog "ObjMessage.DataSource.Save: " & err.Description, 2
AppendLog "Object written", 5
end if
elseif cint(RS.Fields("Act"&i)) = 2 then
elseif cint(RS.Fields("Act"&i)) = 3 then
end if
i=i+1
wend
if RS.Fields("NoMore") = True then RS.MoveLast
end if
RS.MoveNext
Wend

RS.Close
SET RS=Nothing
DB.Close
Set DB=Nothing

EventStatus = 0 ' Done, means cdoRunNextSink
End Sub

sub checkbedingung(feld, vg, wert, checkresult)
' 0 = übergabe ungültiger Werte
' 1 = Bedingung nicht erfüllt
' 4 = Bedingung erfüllt
On Error resume next
AppendLog " Feld: " & feld & " = " & FieldValue(feld) & vg & wert, 5
checkresult=0
if isnull(feld) or feld<1 or feld>11 then
AppendLog " unzulässig: " & checkresult, 5
exit Sub
end if
checkresult=1
if vg="=" then
if FieldValue(feld) = wert then
checkresult=4
end if
elseif vg="/=" then
if FieldValue(feld) <> wert then
checkresult=4
end if
elseif vg="*" then
if islike(FieldValue(feld),"*" & wert) then
checkresult=4
end if
elseif vg="/*" then
if not(islike(FieldValue(feld),"*" & wert)) then
checkresult=4
end if
elseif vg="~" then
if islike(FieldValue(feld),wert) then
checkresult=4
end if
elseif vg="/~" then
if not(islike(FieldValue(feld),wert)) then
checkresult=4
end if
end if
AppendLog " Ergebnis " & vg & ": " & (checkresult=4) & " (" & checkresult & ")", 5
end sub

Sub AppendLog(strLog, errlevel)
'Fügt einen Eintrag in die Log-Datei ein
Dim file
Dim fs

if loglevel>=errlevel then
Set fs = CreateObject("Scripting.FileSystemObject")
Set file = fs.OpenTextFile(logfile, 8, true)
file.Write(Now & ",")
select case errlevel
case 1 file.Write("Fatal Line" & err.Source)
case 2 file.Write("Error ")
case 3 file.Write("Warning ")
case 4 file.Write("Information")
case 5 file.Write("Debug ")
case else file.Write("Code:"&errlevel)
end select
file.WriteLine(","&strLog)
file.Close
end if
End Sub

function entspricht(x,y)
dim i
entspricht=false
if ((instr(y,"?")=0) and (y<>x) ) or (len(x)<>len(y)) then exit function
for i=1 to len(x)
if mid(x,i,1)<>mid(y,i,1) and mid(y,i,1)<>"?" then exit function
next
entspricht=true
end function


function islike(x,y)
Dim Z1,Z2,y1
Dim wcpos
Dim inv

y1=y
inv=left(y1,1)="/"
if inv then y1=right(y1,len(y1)-1)
wcpos=instr(y1,"*")
if wcpos=0 then
islike=entspricht(x,y1) xor inv
exit function
end if
if wcpos=1 and len(y1)>0 then
islike=instr(x,right(y1,len(y1)-1))<>0 xor inv
exit function
end if
z1=left(y1,wcpos-1)
z2=left(x,wcpos-1)
islike=entspricht(z1,z2) xor inv
end function


</SCRIPT>

The log shows:
10.03.2006 14:49:09,Information,NEW MAIL
10.03.2006 14:49:09,Information, FROM:"Jens Banzhaf"
10.03.2006 14:49:09,Information, TO:"Kathrin Engelhardt"
10.03.2006 14:49:09,Information, CC:
10.03.2006 14:49:09,Information, BCC:
10.03.2006 14:49:09,Information, SENDER:
10.03.2006 14:49:09,Information, SUBJECT:Test
10.03.2006 14:49:09,Information, RETURN-PATH xxxx@yyyy.de>
10.03.2006 14:49:09,Information, ENVELOPE-TO:xxxxxxxxxxxx
10.03.2006 14:49:09,Debug , TEXTBODY:Wieder mal Tests - löschen<crlf><crlf>Mit freund ...
10.03.2006 14:49:09,Debug , TEXTBODY-Length:254
10.03.2006 14:49:09,Debug , HTMLBODY: ...
10.03.2006 14:49:09,Debug , HTMLBODY-Length:0
10.03.2006 14:49:09,Information, HASATTACHMENT:Wahr
10.03.2006 14:49:09,Debug , Database Connect established
10.03.2006 14:49:09,Debug , Recordset selected
10.03.2006 14:49:09,Debug , Regeltest: Betreff: SPAM -> weiterleiten an test
10.03.2006 14:49:09,Code:Wahr,WasDas 4:Ungültige Verwendung von Null
10.03.2006 14:49:09,Debug , Regeltest: Betreff: Test -> weiterleiten an ÖO Test
10.03.2006 14:49:09,Code:Wahr,WasDas 3:Ungültige Verwendung von Null
10.03.2006 14:49:09,Code:Wahr,WasDas 4:Ungültige Verwendung von Null
10.03.2006 14:49:09,Debug , Regeltest: Betreff: Virus -> Kopieren in Spam
10.03.2006 14:49:09,Code:Wahr,WasDas 3:Ungültige Verwendung von Null
10.03.2006 14:49:09,Code:Wahr,WasDas 4:Ungültige Verwendung von Null

You can See, that the Object holds the mail until the first call of checkbedingung. After return, it points to Null

Please help