Unique ref number

[AdonPr]

A colleague of mine has given me this script to work with.
What i cant figure out is how to save the email with the ref number in the Inbox. The email with the ref number only goes into sent items after it has been replied to.

! work around i have is to move sent items back to the inbox, then i have 2 emails with the same details 1 with a ref number 1 without!!!

Can anyone help?


Sub AUTOREF(objmail As MailItem)
If (Left(objmail.Subject, 3) = "FW:") Or (Left(objmail.Subject, 3) = "RE:") Then
Exit Sub
End If
On Error Resume Next
'archiving mailbox
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim mItem As MailItem
Dim fSuccess As Boolean

Set olApp = Application
Set olNS = olApp.GetNamespace("MAPI")
' Set objFolder = olNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
'
' ProcessFolder objFolder, ""
'reference number
Set DB = OpenDatabase(Name:="c:\program files\olref.mdb")
Set RS = DB.OpenRecordset(Name:="mail")
RS.MoveLast
NO = RS.REFNO + 1
msg = objmail.Subject
msgbody = objmail.Body
Reply = objmail.SenderName

r = Str(NO)
'objmail.Subject = msg & " Ref.No:" & r
RS.AddNew
RS.REFNO = NO
RS.Date = Date
RS.MESSAGE = msg
RS.Body = msgbody
RS.Reply = Reply
RS.Update
RS.Close
DB.Close
'End
'standard response
Dim strRecip As String
Dim strSubject As String
Dim strMsg As String
Dim strAttachment As String
Set mOutlookApp = GetObject("", "Outlook.application")
Set mNameSpace = mOutlookApp.GetNamespace("MAPI")
Set DB3 = OpenDatabase(Name:="c:\program files\olref.mdb")
Set RS3 = DB3.OpenRecordset(Name:="inbox")
RS3.MoveLast
Set DB4 = OpenDatabase(Name:="c:\program files\olref.mdb")
Set RS4 = DB3.OpenRecordset(Name:="mail")
RS4.MoveLast
strSubject = RS4("Message") & " - Ref No: " & RS4("RefNo")
findRef2 = InStr(objmail.Subject, "Ref")
If findRef2 = 0 Then
objmail.Subject = RS4("Subject") & " - Ref No: " & RS4("RefNo")
objmail.Save
End If
strRecip = RS4("Reply")
strMsg = "This is the standard response part - " & vbCrLf & "---------------------------------" & vbCrLf & RS4("Body")

fSuccess = True
Set mItem = mOutlookApp.CreateItem(olMailItem)
mItem.Recipients.Add strRecip
mItem.Subject = strSubject
mItem.Body = strMsg
findRef = InStr(mItem.Subject, "Ref")
'MsgBox findRef
If findRef > 0 Then
mItem.Save
mItem.Send
End
End If
Set mOutlookApp = Nothing
Set mNameSpace = Nothing
If Err.Number > 0 Then fSuccess = False
SendMessage = fSuccess
RS3.Close
DB3.Close
RS4.Close
DB4.Close
Exit Sub
End
End Sub
'standard response
Private Sub Application_ItemSend(ByVal ITEM As Object, Cancel As Boolean)
findRef = InStr(ITEM.Subject, "Ref")
If (Left(ITEM.Subject, 3) = "FW:") Or (Left(ITEM.Subject, 3) = "RE:") Or findRef > 0 Then
Exit Sub
End If
Call AUTOREF(ITEM)
End Sub
'archiving mailbox
Private Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder, strParentFolder As String)
Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempItem As Object
Set dbConn = CreateObject("ADODB.Connection")
Set dbRS = CreateObject("ADODB.Recordset")
Set DB2 = OpenDatabase(Name:="c:\program files\olref.mdb")
Set RS2 = DB2.OpenRecordset(Name:="inbox")

On Error Resume Next
DB2.Execute ("DELETE * FROM inbox")
DB2.Update
For i = CurrentFolder.Items.Count To 1 Step -1
Select Case CurrentFolder.Items(i).Class
Case olMail
RS2.AddNew
RS2("Subject") = CurrentFolder.Items(i).Subject
RS2("Body") = CurrentFolder.Items(i).Body
RS2("address") = CurrentFolder.Items(i).SenderName
RS2.Update
Case olAppointment
Case olContact
Case olNote
Case olTask
End Select
Next
RS2.Close
DB2.Close
End Sub