I do see what you are saying. I issue a send command earlier in the
routine,
but on a newly created message that does not have all the audit
information
appended to the properties of the outlook message. I do not want to send
a
message with all the audit information back to the customer. Perhaps
instead
of creating the new message I should use the current mailitem and then add
the tags later? I will include the entire routine so you can better see
what
is occurring. Please remember this is an application in development and
sylistically the programming leaves a lot to be desired. At the moment I
jsut want to get it to work ... Ill go back later and remove the GoTo
statements etc. Thanks for your continuing help Dmitry.
----------------------------
Public Sub Reply_Click()
Dim LineNumber As Single
Dim InquiryReason As String
Dim ReasonCode As String
Dim AttachmentString As String
Dim insidecount As Integer
Dim LocalDeptValue As Integer
Dim Attachment As Outlook.Attachment
Dim EntryIDKeyArray() As String
Dim EmailSender, EmailSubject, EmailReceivedTime As String
ServerTime = ReturnServerTime
InquiryReason = EmailManageWindow.EmailReason.Text
If InquiryReason = "" Or IsNull(InquiryReason) Then
MsgBox ("Please select an inquiry type.")
Exit Sub
End If
UserSubject = EmailManageWindow.Subject.Text
UserDate = EmailManageWindow.DateSent.Text
UserSender = EmailManageWindow.Sender.Text
UserBody = EmailManageWindow.Body.Text
' If no EntryId key has been established this is a new message and not a
reply to an existing message
If EntryID = "" Then
GoTo NewEmailSend
End If
Set itms = objFolder.Items
itms.SetColumns ("[Subject],[SenderName],[ReceivedTime],[Mileage]")
EntryIDKeyArray() = Split(EntryID, "#$%^")
EmailSender = EntryIDKeyArray(1)
EmailSubject = EntryIDKeyArray(2)
EmailReceivedTime = EntryIDKeyArray(3)
sFilter = "[SenderName] = '" & Replace(EmailSender, "'", "''") & "' And
[Subject] = '" & Replace(EmailSubject, "'", "''") & "'"
Set itm = itms.Find(sFilter)
Do While Not itm Is Nothing
' Because setting colums removes the seconds portion of the Recieved Time
have to make one final check to determine if this is the correct email
If itm.ReceivedTime = EmailReceivedTime Then
GoTo FoundItem:
End If
Set itm = itms.FindNext
Loop
If itm Is Nothing Then
For Each itm In itms
'MsgBox (itm.Subject)
If TypeName(itm) = "MailItem" Then
If InStr(1, itm.Subject, EmailSubject) > 0 Or itm.Subject = EmailSubject
Then
' MsgBox (itm.SenderName)
If itm.SenderName = EmailSender Then
If itm.ReceivedTime = EmailReceivedTime Then
'MsgBox (itm.Unread)
GoTo FoundItem:
End If
End If
End If
End If
Next
GoTo NoItemFound:
End If
FoundItem:
If SpecificEmail = "" Or IsNull(SpecificEmail) Then
SpecificEmail = emailaccountname
End If
On Error GoTo ErrorFound:
If InStr(1, UserSender, "@") Then
GlobalFrom = UserSender
End If
' Find the numeric code associated with the subject and disposition of the
email for later reporting.
CommandText = "Select Department from tblEmailReason WHERE reason='" &
Replace(InquiryReason, "'", "''") & "' AND (MailBox IS Null OR MailBox<1
OR
MailBox=" & MailBoxID & ")"
Set cmd = New ADODB.Command
With cmd
.CommandText = CommandText
.CommandType = adCmdText
.CommandTimeout = 20
.ActiveConnection = ConnString
End With
Set rs = cmd.Execute
If Not rs.EOF And Not rs.BOF Then
LocalDeptValue = Trim(rs.Fields("Department").Value)
End If
CommandText = "Select reasoncode from tblEmailReason WHERE Active=1 AND
Department=" & LocalDeptValue & " AND reason='" & Replace(InquiryReason,
"'",
"''") & "' AND (MailBox IS Null OR MailBox<1 OR MailBox=" & MailBoxID &
")"
Set cmd = New ADODB.Command
With cmd
.CommandText = CommandText
.CommandType = adCmdText
.CommandTimeout = 20
.ActiveConnection = ConnString
End With
Set rs = cmd.Execute
If Not rs.EOF And Not rs.BOF Then
ReasonCode = rs.Fields("reasoncode").Value
End If
' Add new item to be returned to the customer
Set objDummy = objFolder.Items.Add
For insidecount = 0 To
EmailManageWindow.IncludedAttachmentsList.ListCount
AttachmentString =
EmailManageWindow.IncludedAttachmentsList.List(insidecount)
If AttachmentString <> "" And Not (IsNull(AttachmentString)) Then
Set Attachment = objDummy.Attachments.Add(AttachmentString, 1, ,
AttachmentString)
End If
Next
'Special Coding for Best Rate mailboxes
NewEmailSend:
Set cmd = New ADODB.Command
CommandText = "Select emailaccountname, OutEmail,outfolder from
tblEmailAccounts WHERE emailaccount='" & SpecificEmail & " '"
With cmd
.CommandText = CommandText
.CommandType = adCmdText
.CommandTimeout = 20
.ActiveConnection = ConnString
End With
Set rs = cmd.Execute
If Not rs.EOF And Not rs.BOF Then
SpecificEmailOut = rs.Fields("outfolder").Value
OutEmail = rs.Fields("OutEmail").Value
emailaccountname = rs.Fields("emailaccountname").Value
Else
GoTo NoOutFolderErr
End If
If OutEmail = "Best Rate" Then
objDummy.DeleteAfterSubmit = True
With objDummy
.SentOnBehalfOfName = "(e-mail address removed)"
.To = GlobalFrom
.Unread = True
.VotingResponse = ReasonCode
.Body = UserBody
.Subject = UserSubject
.RemoteStatus = AgentCode
.Mileage = AuditInfo & "," & Date & " " & Time
If EmailManageWindow.CCTextBox.Text <> "" And Not
(IsNull(EmailManageWindow.CCTextBox.Text)) Then
.CC = EmailManageWindow.CCTextBox.Text
End If
If Trim(EmailManageWindow.BCCTextBox.Text) <> "" And Not
(IsNull(EmailManageWindow.BCCTextBox.Text)) Then
.BCC = EmailManageWindow.BCCTextBox.Text
End If
.DeleteAfterSubmit = True
.Send
End With
' End hard Coding for Best Rate mailbox"
Else
If GlobalFrom = "" Then
GlobalFrom = EmailManageWindow.Sender.Text
End If
If OutEmail = "" Then
OutEmail = EmailManageWindow.RenderedEmail.Text
End If
With objDummy
.SentOnBehalfOfName = OutEmail
.To = GlobalFrom
.Unread = True
If ReasonCode <> "" Then
.VotingResponse = ReasonCode
End If
.Body = UserBody
.Subject = UserSubject
.RemoteStatus = AgentCode
.Mileage = AuditInfo & "," & Date & " " & Time
If EmailManageWindow.CCTextBox.Text <> "" And Not
(IsNull(EmailManageWindow.CCTextBox.Text)) Then
.CC = EmailManageWindow.CCTextBox.Text
End If
If Trim(EmailManageWindow.BCCTextBox.Text) <> "" And Not
(IsNull(EmailManageWindow.BCCTextBox.Text)) Then
.BCC = EmailManageWindow.BCCTextBox.Text
End If
.DeleteAfterSubmit = True
.Send
End With
End If
' Special Hard Coded Processing For Best Rate mailbox"
If emailaccountname = "Best Rate" Then
If ReasonCode = 140 Or ReasonCode = 141 Or ReasonCode = 142 Then
Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders("Mailbox - Best Rate Yes")
Set objFolder = oParentFolder.Folders.Item("Inbox")
Set objDummy = objFolder.Items.Add
objDummy.DeleteAfterSubmit = True
With objDummy
.Sender = GlobalFrom
.To = "(e-mail address removed)"
.Unread = True
.VotingResponse = ReasonCode
.Body = UserBody
.Subject = UserSubject
.RemoteStatus = AgentCode
.Mileage = AuditInfo & "," & Date & " " & Time
If EmailManageWindow.CCTextBox.Text <> "" And Not
(IsNull(EmailManageWindow.CCTextBox.Text)) Then
.CC = EmailManageWindow.CCTextBox.Text
End If
If Trim(EmailManageWindow.BCCTextBox.Text) <> "" And Not
(IsNull(EmailManageWindow.BCCTextBox.Text)) Then
.BCC = EmailManageWindow.BCCTextBox.Text
End If
.FlagRequest = ServerTime
.DeleteAfterSubmit = True
.Send
End With
Else
Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders("Mailbox - Best Rate No")
Set objFolder = oParentFolder.Folders.Item("Inbox")
Set objDummy = objFolder.Items.Add
objDummy.DeleteAfterSubmit = True
With objDummy
.To = "(e-mail address removed)"
.Unread = True
.VotingResponse = ReasonCode
.Body = UserBody
.Subject = UserSubject
.RemoteStatus = AgentCode
.DeleteAfterSubmit = True
.Mileage = AuditInfo & "," & Date & " " & Time
If EmailManageWindow.CCTextBox.Text <> "" And Not
(IsNull(EmailManageWindow.CCTextBox.Text)) Then
.CC = EmailManageWindow.CCTextBox.Text
End If
If Trim(EmailManageWindow.BCCTextBox.Text) <> "" And Not
(IsNull(EmailManageWindow.BCCTextBox.Text)) Then
.BCC = EmailManageWindow.BCCTextBox.Text
End If
.FlagRequest = ServerTime
.DeleteAfterSubmit = True
.Send
End With
End If
End If
Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders(SpecificEmail)
If oParentFolder.Folders.count Then
For insidecount = 1 To oParentFolder.Folders.count
If oParentFolder.Folders.Item(insidecount).Name = SpecificEmailOut Then
Set objFolderReply = oParentFolder.Folders.Item(insidecount)
inboxnumber = insidecount
GoTo FoundFolder
End If
Next
End If
FoundFolder:
If strname <> "" Then
Set objDummy = objApp.CreateItem(olMailItem)
Set objRecip = objNS.CreateRecipient(strname)
objRecip.Resolve
If objRecip.Resolved = True Then
On Error Resume Next
If objFolder Is Nothing Then
MsgBox "Cannot open '" + SpecificEmailOut + "' folder. Make
sure '" + objRecip.Name + "' has granted access.", , "Error"
Else
Dim found
found = False
countvariable = 0
End If
End If
End If
On Error Resume Next
If EntryID = "" Then
UserSender = EmailManageWindow.Sender.Text
UserBody = EmailManageWindow.Body.Text
UserSubject = EmailManageWindow.Subject.Text
With objDummy
.SentOnBehalfOfName = emailaccountname
.To = UserSender
.Unread = True
.VotingResponse = ReasonCode
.Body = UserBody
.Subject = UserSubject
.RemoteStatus = AgentCode
.Mileage = AuditInfo & "," & Date & " " & Time
.FlagRequest = ServerTime
.Move objFolderReply
End With
Else
' MsgBox (UserDepartmentID)
With itm
.SentOnBehalfOfName = emailaccountname
.To = UserSender
.VotingResponse = ReasonCode
.Body = UserBody
.Subject = UserSubject
.RemoteStatus = AgentCode
.Mileage = AuditInfo & "," & Date & " " & Time
.FlagRequest = ServerTime
.Unread = True
.Move objFolderReply
.DeleteAfterSubmit = True
End With
End If
EmailManageWindow.Hide
ManageAccounts True, "SpecificEmail", SpecificEmail, SubFolder
Exit Sub
NoItemFound:
Exit Sub
ErrorFound:
MsgBox ("The following error was encountered on line " & LineNumber & " :
"
& Err.Description & vbCrLf & vbCrLf & "Source: " & Err.Source)
Exit Sub
NoOutFolderErr:
MsgBox ("No Sent Folder has been specified for this account. Please
contact
a System Administrator")
End Sub
Dmitry Streblechenko said:
Since you want the message to be moved to a different store, do use the
MAPIFolder.Items.ItemAdd
event on the Sent Items folder to grab the message after it was sent and
explicuitly move. But that must be done *after* the mesage is sent and
moved
to the Sent Items folder.
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
