Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 03-14-2006, 02:30 PM
jehemo2001 jehemo2001 is offline
Novice
Object in SMTPSink looses Value
 
Join Date: Mar 2006
Posts: 1
jehemo2001
Default Object in SMTPSink looses Value

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
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Access Object library 10 Gyto Office 0 10-09-2008 09:04 AM
Redemption object and outlook knut Outlook 0 09-24-2007 03:55 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:37 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft