Hi,
I am trying to develop a Email base news group in which I want to send
some information like messageID which is coming from the database along
with the mail to the listed users.
I am using Exchange 5.5 on Wondows NT 4, using CDO 1.2 Lib.
I have tried to use Categories Property of the Message Object. This is
working fine with in the Intranet, but it failed to work on internet all
the header information is lost when it goes out.
Sending you some sample code along with this....
For sending mail .........
Public Sub SendMailToUserList(strSubject As String, strMessage As String,
strUserEmailList As String, intMessageID As Integer)
Dim strEmail As String
Dim stra(1) As String
On Error GoTo hError
stra(0) = Str(intMessageID)
Dim test As Variant
Set objMessage = objSession.Outbox.Messages.Add
With objMessage
.Subject = strSubject
.Text = strMessage '& strUserEmailList
m_objReadINI.CreateLog Now & "Message ID Send :" & stra(0)
.Categories = stra
.Update
End With
While strUserEmailList <> ""
intPos = InStr(strUserEmailList, ";")
If intPos <> 0 Then
strEmail = Left(strUserEmailList, intPos - 1)
strUserEmailList = Mid(strUserEmailList, intPos + 1)
Else
strEmail = strUserEmailList
strUserEmailList = ""
End If
Set objRecip = objMessage.Recipients.Add
objRecip.Name = strEmail
objRecip.Type = CdoTo
objRecip.Resolve
objMessage.Update
Wend
m_objReadINI.CreateLog Now & "Updating Message object"
objMessage.Update
m_objReadINI.CreateLog Now & "Sending Mail "
objMessage.Send
Exit Sub
hError:
m_objReadINI.CreateLog "Error In function SendMailToUserList at" & Now
& " :" & Err.Description
End Sub
For Scanning Inbox for new mail ....
Public Sub CheckForNewMail()
Dim objLocalMsg As Object
Dim intCounter As Integer
Dim strEmail As String
Dim strSubject As String
Dim strMessage As String
Dim strArr As Variant
Dim intCatCounter As Integer
Dim bCheckUser As Boolean
Dim intUserID As Integer
Dim strFilter As String
Dim strAddress As String
Dim bCheckAddress As Boolean
Dim bCheckUserEmail As Boolean
'Dim colRecips As MAPI.Recipient
On Error GoTo hError
Set objInbox = objSession.Inbox
Set objLocalMsg = objInbox.Messages
m_objReadINI.CreateLog Now & "Checking For New mails "
For intCounter = 1 To objLocalMsg.Count
'Set colRecips = objLocalMsg(intCounter).Recipient
'MsgBox colRecips.Name
strEmail = ""
strSubject = ""
strMessage = ""
strEmail = objLocalMsg(intCounter).Sender.Name
strAddress = objLocalMsg(intCounter).Sender.Address
m_objReadINI.CreateLog Now & "Name prop. " & strEmail
m_objReadINI.CreateLog Now & "Address Prop. " & strAddress
strFilter = objLocalMsg(intCounter).Type
If Trim(UCase(strFilter)) <> "REPORT.IPM.NOTE.NDR" Then
bCheckUser = m_objDatabase.CheckUserEmail(strEmail)
bCheckAddress = m_objDatabase.CheckUserEmail(strAddress)
m_objReadINI.CreateLog " Name Flag " & bCheckUser
m_objReadINI.CreateLog " Address Flag " & bCheckAddress
If Not bCheckAddress Then
'If Not bCheckUser Then
m_objReadINI.CreateLog Now & "Not a valid user " &
strEmail & ";" & strAddress
Call fncSendMailToUnAuthorisedUser("Not Authorised User",
strEmail & ";" & strAddress)
Else
'MsgBox objLocalMsg(intCounter).Filter.Sender.Name
strSubject = objLocalMsg(intCounter).Subject
strMessage = objLocalMsg(intCounter).Text
intUserID = m_objDatabase.GetUserIDByEmail(strAddress)
'intUserID = m_objDatabase.GetUserIDByEmail(strEmail)
DoEvents
'm_objReadINI.CreateLog Now & "Checking for Message Header
Values ----------------- Start -------"
'm_objReadINI.CreateLog Now & "Checking for Message LBound
of the Header Array -----------------" &
LBound(objLocalMsg(intCounter).Categories) & " -------"
'm_objReadINI.CreateLog Now & "Checking for Message UBound
of the Header Array -----------------" &
UBound(objLocalMsg(intCounter).Categories) & " -------"
' strArr = objLocalMsg(intCounter).Categories
'
' m_objReadINI.CreateLog Now & "Testing of Categories"
' m_objReadINI.CreateLog Now &
objLocalMsg(intCounter).Categories
'm_objReadINI.CreateLog Now & "Checking for Message Header
Values ----------------- End -------"
If IsArray(objLocalMsg(intCounter).Categories) Then
m_objReadINI.CreateLog Now & "Inside the array
category"
For intCatCounter =
LBound(objLocalMsg(intCounter).Categories) To
UBound(objLocalMsg(intCounter).Categories)
m_objReadINI.CreateLog Now & "Checking UBound of the
array."
If 0
< Len(objLocalMsg(intCounter).Categories()(intCatCounter)) Then
strArr(0) =
objLocalMsg(intCounter).Categories()(intCatCounter)
If IsNumeric(strArr(0)) Then
m_objReadINI.CreateLog Now & "Updating
database for a reply "
m_objReadINI.CreateLog " EXEC
MN_VBinsertIntoMessage_SP 1,'" & Replace(strSubject, "'", "''") & "','" &
strMessage & "',1 ," & CInt(strArr(0))
m_objDatabase.OpenConnection.Execute "
EXEC MN_VBinsertIntoMessage_SP 1,'" & Replace(strSubject, "'", "''") &
"','" & Replace(strMessage, "'", "''") & "'," & intUserID & " ," &
CInt(strArr(0))
Else
m_objReadINI.CreateLog Now & "Updating
database for a new messagegfgfgfgfg"
m_objReadINI.CreateLog " EXEC
MN_VBinsertIntoMessage_SP 1,'" & strSubject & "','" & strMessage & "',1
," & CInt(strArr(0))
m_objDatabase.OpenConnection.Execute "
EXEC MN_VBinsertIntoMessage_SP 1,'" & Replace(strSubject, "'", "''") &
"','" & Replace(strMessage, "'", "''") & "'," & intUserID & " ," &
CInt(strArr(0))
End If
End If
Next intCatCounter
Else
m_objReadINI.CreateLog Now & "Updating database for a
new message "
m_objReadINI.CreateLog " EXEC
MN_VBinsertIntoMessage_SP 1,'" & strSubject & "','" & strMessage & "',1 "
m_objDatabase.OpenConnection.Execute " EXEC
MN_VBinsertIntoMessage_SP 1,'" & Replace(strSubject, "'", "''") & "','" &
Replace(strMessage, "'", "''") & "', " & intUserID
End If
End If
End If
m_objReadINI.CreateLog Now & "Deleting message from the Inbox"
objLocalMsg(intCounter).Delete
Next
Exit Sub
hError:
m_objReadINI.CreateLog "Error In function CheckForNewMail at" & Now &
" :" & Err.Description
End Sub
Thanks in advance.
Regards,
Akhil Min
_________________________________________________________________
List posting FAQ: http://www.swinc.com/resource/exch_faq.htm
Archives: http://www.swynk.com/sitesearch/search.asp
To unsubscribe: mailto:[EMAIL PROTECTED]
Exchange List admin: [EMAIL PROTECTED]
