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