Outlook gönderilen maillere Referans numarası eklemek

Outlook gönderilen maillere Referans numarası eklemek için,

Outlook da gönderilen her maile aşağıdaki şekilde referans numarası eklenebilir.
Kayıt defterinde referans numarası bulunmuyor ise 0000000 kodunu kayıt eder ve her mail gönder işlemi yapıldığında bu numarayı arttırır.
Mail giden kutusuna düştüğünde program kayıt defterine son numarayı kaydeder.

Outlook da makroların etkinleştirilmiş olması gerekiyor. Kodları ekledikten sonra VBA bölümünde kayıt ikonunu tıklayın. Outlook u kapatıp açın.

REF:XXXXXXX@-AHM XXXXXXXXX/XXXXXXX X dışındaki alanlar sabit alanlardır. Siz ihtiyacınıza göre numarastr değişkenindeki tanımlamaları değiştirebilirsiniz.

REF:0000001@-AHM 9.02.2021/23:23:23
REF:0000002@-AHM 9.02.2021/23:24:03
REF:0000003@-AHM 9.02.2021/23:25:01

 

Bu kodu ThisOutlookSession bölümüne kaydediniz.

Private Sub Application_Startup()
Set m_Explorer = Application.ActiveExplorer
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
tarih = Date
saat = Time
If Left(Item.Body, 4) <> “REF:” Then
On Error Resume Next
sirano = regoku(“SiraNumarasi”)
On Error GoTo 0
sirano = numarator(sirano)
numarastr = “REF:” & sirano & “@-AHM ” & tarih & “/” & saat
‘Item.Subject = numarastr & ” ” & Item.Subject
‘Item.Body = numarastr & ” ” & Item.Body
‘Item.HTMLBody = numarastr & ” ” & Item.HTMLBody
Item.Save
Item.HTMLBody = Item.EntryID & ” ” & Item.HTMLBody

On Error Resume Next
Call regkaydet(“SiraNumarasi”, sirano)
On Error GoTo 0
End If
End Sub

 

 

MODUL1 içinde bulunması gereken kodlar.

Dim veri() As String
Dim adet As Long
Dim elde, bakilansayi As Boolean
Const harfler As String = “ABCDEFGĞHIİJKLMNOÖPRSŞTUÜXWVYZ”
Const sayilar As String = “0123456789”
‘Const sayilar As String = “01”
Const dahildegil As String = “.-/”
Public sirano As String

Function numarator(numara) As String
numara = StrReverse(numara)
adet = Len(numara)
ReDim Preserve veri(1 To adet)
For i = 1 To adet
veri(i) = Mid(numara, i, 1)
Next i

elde = False
For j = LBound(veri) To UBound(veri)
harf = veri(j)
If InStr(dahildegil, harf) > 0 Then GoTo son
bakilansayi = sayimi(harf)
If bakilansayi Then
veri(j) = sayiarttir(harf)
Else
veri(j) = harfarttir(harf)
End If

If elde = False Then
Exit For
End If
son:
Next j

For i = LBound(veri) To UBound(veri)
veristr = veristr & veri(i)
Next i

veristr = StrReverse(veristr)
If Left(veristr, 1) = Left(sayilar, 1) And elde Then
numarator = “1” & veristr
ElseIf Left(veristr, 1) = Left(harfler, 1) And elde Then
numarator = Left(harfler, 1) & veristr
Else
numarator = veristr
End If
End Function

Function harfarttir(harfstr) As String
mevcutsira = InStr(harfler, harfstr)
yenisira = Mid(harfler, mevcutsira + 1, 1)
If yenisira = “” Then
harfarttir = Mid(harfler, 1, 1)
elde = True
Else
harfarttir = yenisira
elde = False
End If
End Function

Function sayiarttir(sayistr) As String
mevcutsira = InStr(sayilar, sayistr)
yenisira = Mid(sayilar, mevcutsira + 1, 1)
If yenisira = “” Then
sayiarttir = Mid(sayilar, 1, 1)
elde = True
Else
sayiarttir = yenisira
elde = False
End If
End Function

Function sayimi(sadecesayistr)
liste = “0123456789”
For k = 1 To Len(sadecesayistr)
harf = Mid(sadecesayistr, k, 1)
If InStr(liste, harf) = 0 Then
sayimi = False
Exit Function
End If
Next k
sayimi = True
End Function

Sub regkaydet(regisim As String, regveri As String)
On Error Resume Next
CreateObject(“WScript.Shell”).RegWrite “HKCU\Software\OutlookRefNo\” & regisim, regveri, “REG_SZ”
If regisim = “ozelsecimtasikarakter” Then
a = a
End If

If regveri = “” Then
CreateObject(“WScript.Shell”).RegDelete “HKCU\Software\OutlookRefNo\” & regisim
End If
On Error GoTo 0
End Sub

Function regoku(regisim As String) As String
On Error Resume Next
regoku = CreateObject(“WScript.shell”).Regread(“HKCU\Software\OutlookRefNo\” & regisim)
If regoku = “” And regisim = “SiraNumarasi” Then regoku = “0000000”
On Error GoTo 0
End Function

 

 

 

label,

About the author

Add a Comment