assign unique number email

zemestan

Member
Outlook version
Outlook 2007
Email Account
POP3
hello

we used outlook for send/recieve letters and message in our company

i have a question:

we need to assign one unique number to each mail/message.so that ID used for mail Identification.

this is for future refrence and search

this option can be outlook or in other Office App. that related with outlook...

Is there a solution..??

with thanks
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
You'll need to use VBA to do it. Do you need to increment the number? You can use a text file and vba in all office apps can get the number from it.

This is the code snippet i use for an invoice # - it's incremented after each use.

Code:
Dim enviro As String 
 
enviro = CStr(Environ("USERPROFILE")) 
 
Invoice = System.PrivateProfileString(enviro & "\Templates\invoice-number.txt", _
       "MacroSettings", "Invoice") 
 
If Invoice = "" Then
   Invoice = 1 
 
Else
   Invoice = Invoice + 1 
 
End If 
 
System.PrivateProfileString(enviro & "\Templates\invoice-number.txt", "MacroSettings", _
       "Invoice") = Invoice
 

apugarte

Member
I Tried to copy this onto this code...

Public WithEvents myOlApp As Outlook.Application

Private Sub Application_Startup()
Initialize_Handler

End Sub

Public Sub Initialize_handler()
Set myOlApp = CreateObject("Outlook.Application")

End Sub

Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
If InStr(1, Item.Subject, "Privacy", vbTextCompare) = False Then
Item.Subject = "Privacy " & Item.Subject
End If

End Sub

As you may imagine I need to assign a unique number to every message I send... but I couldn't figure out what to remove or where to insert the code ...

Can you help me???

Thanks!
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
The invoice code is word code and it needs tweaked to work in outlook - but what i thought i needed to do to tweak it, didn't work. :(

See Outlook Addins, Macros & Tips - VBOffice for one option. (Michael's Send macros are listed at Outlook VBA Macros - VBOffice )

Sequential numbers, stored in registry:

Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim sAppName As String
Dim sSection As String
Dim sKey As String
Dim lRegValue As Long
Dim lFormValue As Long
Dim iDefault As Integer
sAppName = "Word 2000"
sSection = "Invoices"
sKey = "Current Invoice Number"
' The default starting number.
iDefault = 101
' Get stored registry value, if any.
lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
' If the result is zero, set to default value.
If lRegValue < 100 Then lRegValue = iDefault
' Increment and update invoice number.
SaveSetting sAppName, sSection, sKey, lRegValue + 1

Errhandler:
If Err <> 0 Then
MsgBox Err.Description
End If


Item.Subject = CStr(lRegValue) & Item.Subject

End Sub

for random numbers, try this:

Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)

intHighNumber = 10000

intLowNumber = 1
Randomize
intNumber = Int((intHighNumber - intLowNumber + 1) * Rnd + intLowNumber)
Item.Subject = intNumber & Item.Subject

End Sub

This one does 5 random characters (alphanumberic)

Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.Subject = GetRandom(5) & Item.Subject ' change 5 to another number for longer key

End Sub

Function GetRandom(Count)
Randomize
For i = 1 To Count
If (Int((1 - 0 + 1) * Rnd + 0)) Then
GetRandom = GetRandom & Chr(Int((90 - 65 + 1) * Rnd + 65))
Else
GetRandom = GetRandom & Chr(Int((57 - 48 + 1) * Rnd + 48))
End If
Next

End Function
 
Last edited:

apugarte

Member
Thank you so much...




Yesterday the first code worked fine... Today I received an error on this line:




Set myOlApp = CreateObject("Outlook.Application")




(The error - 2146959355 (8008005), it says that probably I need to reinstall my program)




So I couldn't try your suggestion :(




I am using this exactly:





Public WithEvents myOlApp As Outlook.Application



Private Sub Application_Startup()
Initialize_handler


End Sub



Public Sub Initialize_handler()
Set myOlApp = CreateObject("Outlook.Application")


End Sub



Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)

If InStr(1, Item.Subject, "Privacy", vbTextCompare) = False Then
Item.Subject = "Privacy " & Item.Subject
End If


End Sub






Any suggestions????
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
I don't think you need to reinstall. Does the error say anything besides the code?
 

apugarte

Member
It says somethin like this:

Maybe the program which created the attachment is not installed properly or been moved or deleted. Reinstall the program (I have a spanish OL version)
 

jrobertson1983

New Member
Outlook version
Outlook 2016 64 bit
Email Account
Exchange Server
Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.Subject = GetRandom(5) & Item.Subject ' change 5 to another number for longer key

End Sub

Function GetRandom(Count)
Randomize
For i = 1 To Count
If (Int((1 - 0 + 1) * Rnd + 0)) Then
GetRandom = GetRandom & Chr(Int((90 - 65 + 1) * Rnd + 65))
Else
GetRandom = GetRandom & Chr(Int((57 - 48 + 1) * Rnd + 48))
End If
Next

End Function

Hi Diane - learning so much from you. I tried to copy and paste the code above, but when I go to run the Macro, GetRandom or myOIApp_ItemSend does not show up? I am running outlook 2016 on an exchange server, is there something I can update in the code so it's read by Outlook 2016?
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Functions are called from other macros and item send (and other automatic macros) are not listed in the macro picker as you can't run them manually.

Did you put the itemsend macro in ThisOutlookSession? That's all you need to do.
 

Similar threads

Top